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);
}
/* 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;
}
static obj_ptr _add(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKINT(0);
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
if (INTP(arg))
{
if (FLOATP(res))
FLOAT(res) += (double)INT(arg);
else
INT(res) += INT(arg);
}
else if (FLOATP(arg))
{
if (INTP(res))
{
int n = INT(res);
res->type = TYPE_FLOAT;
FLOAT(res) = (double)n;
}
FLOAT(res) += FLOAT(arg);
}
else
{
res = MKERROR(MKSTRING("Expected a number in +"), arg);
break;
}
}
return res;
}
CELL func_substring(CELL frame)
{
CELL string = FV0;
CELL start = FV1;
CELL end = FV2;
if (!STRINGP(string)) {
return make_exception("expects a string");
}
if (!INTP(start)) {
return make_exception("expects a non-negative start index");
}
if (!INTP(end)) {
return make_exception("expects a non-negative end index");
}
size_t len = GET_STRING(string)->len;
size_t starti = GET_INT(start);
size_t endi = GET_INT(end);
if (starti < 0 || starti > len) {
return make_exception("start index %d out of range [0,%d]", starti, len);
}
if (endi < starti || endi > len) {
return make_exception("end index %d out of range [%d,%d]", endi, starti, len);
}
gc_root_1("func_substring", string);
CELL result = make_string_raw(endi - starti);
gc_unroot();
memcpy(GET_STRING(result)->data, GET_STRING(string)->data + starti, endi - starti);
return result;
}
// 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;
}
static int int_comp(void *p1v, void *p2v)
{
char *p1=(char *)p1v;
char *p2=(char *)p2v;
int i1 = *INTP( p1 ) ;
int i2 = *INTP( p2 ) ;
COMPARE( i1, i2 ) ;
}
int main(void)
{
dict_h lh ;
dict_iter iter ;
int i ;
int *ip ;
lh = dll_create( int_comp, int_kcomp, 0 ) ;
for ( i = 0 ; i < N ; i++ )
{
nums[ i ] = 10-i ;
if ( dll_insert( lh, &nums[ i ] ) != DICT_OK )
{
printf( "Failed at %d\n", i ) ;
exit( 1 ) ;
}
}
printf( "Successor test\n" ) ;
for ( ip=INTP(dll_minimum( lh )) ; ip ; ip=INTP(dll_successor( lh, ip )) )
printf( "%d\n", *ip ) ;
printf( "Predecessor test\n" ) ;
for ( ip=INTP(dll_maximum( lh )) ; ip ; ip=INTP(dll_predecessor( lh, ip )) )
printf( "%d\n", *ip ) ;
printf( "Search/delete test\n" ) ;
i = 7 ;
ip = INTP( dll_search( lh, &i ) ) ;
if ( ip == NULL )
printf( "Search failed\n" ) ;
else
if ( dll_delete( lh, ip ) != DICT_OK )
{
printf( "Delete failed\n" ) ;
exit( 0 ) ;
}
printf( "Successor test 2\n" ) ;
for ( ip=INTP(dll_minimum( lh )) ; ip ; ip=INTP(dll_successor( lh, ip )) )
printf( "%d\n", *ip ) ;
printf( "Predecessor test 2\n" ) ;
for ( ip=INTP(dll_maximum( lh )) ; ip ; ip=INTP(dll_predecessor( lh, ip )) )
printf( "%d\n", *ip ) ;
printf( "Iteration test\n" ) ;
iter = dll_iterate( lh, DICT_FROM_START ) ;
while (( ip = INTP( dll_nextobj( lh, iter ) ) ))
if ( *ip == 5 )
(void) dll_delete( lh, ip ) ;
else
printf( "%d\n", *ip ) ;
exit( 0 ) ;
}
static int int_kcomp(void *p1v, void *p2v)
{
char *p1=(char *)p1v;
char *p2=(char *)p2v;
int k = *INTP( p1 ) ;
int obj = *INTP( p2 ) ;
COMPARE( k, obj ) ;
}
static obj_ptr _sub(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKINT(0);
int ct = 0;
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
ct++;
if (NINTP(arg) && NFLOATP(arg))
{
res = MKERROR(MKSTRING("Expected a number in -"), arg);
return res;
}
else if (ct == 1)
{
if (INTP(arg))
INT(res) = INT(arg);
else
{
res->type = TYPE_FLOAT;
FLOAT(res) = FLOAT(arg);
}
}
else if (INTP(arg))
{
if (FLOATP(res))
FLOAT(res) -= (double)INT(arg);
else
INT(res) -= INT(arg);
}
else if (FLOATP(arg))
{
if (INTP(res))
{
int n = INT(res);
res->type = TYPE_FLOAT;
FLOAT(res) = (double)n;
}
FLOAT(res) -= FLOAT(arg);
}
}
if (ct == 1)
{
if (INTP(res))
INT(res) *= -1;
else
FLOAT(res) *= -1;
}
return res;
}
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;
}
// 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;
}
static uim_lisp
c_getaddrinfo(uim_lisp hostname_, uim_lisp servname_, uim_lisp hint_)
{
const char *hostname;
char *servname = NULL;
struct addrinfo *hints = C_PTR(hint_);
struct addrinfo *res, *res0;
uim_lisp ret_ = uim_scm_null();
int error;
if (INTP(servname_)) {
uim_asprintf(&servname, "%d", C_INT(servname_));
} else {
servname = C_STR(servname_);
}
if (FALSEP(hostname_))
hostname = NULL;
else
hostname = REFER_C_STR(hostname_);
error = getaddrinfo(hostname, servname, hints, &res0);
if (error) {
const char *errstr = gai_strerror(error);
uim_notify_fatal("getaddrinfo: %s", errstr);
free(servname);
return uim_scm_f();
}
free(servname);
for (res = res0; res; res = res->ai_next) {
ret_ = CONS(MAKE_PTR(res) , ret_);
}
return uim_scm_callf("reverse", "o", ret_);
}
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;
}
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;
}
static uim_lisp
home_directory(uim_lisp user_)
{
int uid;
char home[MAXPATHLEN];
if (INTP(user_)) {
uid = C_INT(user_);
} else if (STRP(user_)) {
struct passwd *pw;
pw = getpwnam(REFER_C_STR(user_));
if (!pw)
return uim_scm_f();
uid = pw->pw_uid;
endpwent();
} else {
return uim_scm_f();
}
if (!uim_get_home_directory(home, sizeof(home), uid)) {
char *home_env = getenv("HOME");
if (home_env)
return MAKE_STR(home_env);
return uim_scm_f();
}
return MAKE_STR(home);
}
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;
}
CELL func_integer_to_char(CELL frame)
{
if (!(INTP(FV0) && GET_INT(FV0) >= 0 && GET_INT(FV0) <= 255)) {
return make_exception("expects an <integer> in [0,255]");
}
return make_char(GET_INT(FV0));
}
object_t *integerp (object_t * lst)
{
DOC ("Return t if object is an integer.");
REQ (lst, 1, c_sym ("integerp"));
if (INTP (CAR (lst)))
return T;
return NIL;
}
static obj_ptr _decrement(obj_ptr arg, obj_ptr env)
{
if (INTP(arg))
return MKINT(INT(arg) - 1);
if (FLOATP(arg))
return MKFLOAT(FLOAT(arg) - 1.0);
return MKERROR(MKSTRING("Expected a number in --"), arg);
}
static ScmObj
scm_p_set_macro_debug_flagsx(ScmObj new_mode)
{
SCM_ASSERT(INTP(new_mode));
l_debug_mode = SCM_INT_VALUE(new_mode);
return SCM_UNDEF;
}
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));
}
PyObject* scalapack_redist(PyObject *self, PyObject *args)
{
PyArrayObject* a; // source matrix
PyArrayObject* b; // destination matrix
PyArrayObject* desca; // source descriptor
PyArrayObject* descb; // destination descriptor
char uplo;
char diag='N'; // copy the diagonal
int c_ConTxt;
int m;
int n;
int ia, ja, ib, jb;
if (!PyArg_ParseTuple(args, "OOOOiiiiiiic",
&desca, &descb,
&a, &b,
&m, &n,
&ia, &ja,
&ib, &jb,
&c_ConTxt,
&uplo))
return NULL;
if (uplo == 'G') // General matrix
{
if (a->descr->type_num == PyArray_DOUBLE)
Cpdgemr2d_(m, n,
DOUBLEP(a), ia, ja, INTP(desca),
DOUBLEP(b), ib, jb, INTP(descb),
c_ConTxt);
else
Cpzgemr2d_(m, n,
(void*)COMPLEXP(a), ia, ja, INTP(desca),
(void*)COMPLEXP(b), ib, jb, INTP(descb),
c_ConTxt);
}
else // Trapezoidal matrix
{
if (a->descr->type_num == PyArray_DOUBLE)
Cpdtrmr2d_(&uplo, &diag, m, n,
DOUBLEP(a), ia, ja, INTP(desca),
DOUBLEP(b), ib, jb, INTP(descb),
c_ConTxt);
else
Cpztrmr2d_(&uplo, &diag, m, n,
(void*)COMPLEXP(a), ia, ja, INTP(desca),
(void*)COMPLEXP(b), ib, jb, INTP(descb),
c_ConTxt);
}
Py_RETURN_NONE;
}
CELL func_make_string(CELL frame)
{
if (!(INTP(FV0) && GET_INT(FV0) >= 0)) {
return make_exception("1st argument expects non-negative integer");
}
if (FC == 2 && !CHARP(FV1)) {
return make_exception("2nd argument expects character");
}
return make_string_filled(GET_INT(FV0), (FC == 2) ? GET_CHAR(FV1) : -1);
}
static obj_ptr _floor(obj_ptr arg, obj_ptr env)
{
if (INTP(arg))
return arg;
if (FLOATP(arg))
{
int x = (int)FLOAT(arg);
return MKINT(x);
}
return MKERROR(MKSTRING("Expected a number in floor"), arg);
}
int main(void)
{
dict_h lh ;
dict_iter iter ;
int i ;
int *ip ;
struct ht_args args ;
args.ht_bucket_entries = 2 ;
args.ht_table_entries = 2 ;
args.ht_objvalue = getval ;
args.ht_keyvalue = getval ;
lh = ht_create( int_comp, int_comp, 0, &args ) ;
for ( i = 0 ; i < N ; i++ )
{
nums[ i ] = 10-i ;
if ( ht_insert( lh, &nums[ i ] ) != DICT_OK )
{
printf( "Failed at %d\n", i ) ;
exit( 1 ) ;
}
}
printf( "Search/delete test\n" ) ;
i = 7 ;
ip = INTP( ht_search( lh, &i ) ) ;
if ( ip == NULL )
printf( "Search failed\n" ) ;
else
if ( ht_delete( lh, ip ) != DICT_OK )
{
printf( "Delete failed\n" ) ;
exit( 0 ) ;
}
for ( i = 0 ; i < N ; i++ )
if (( ip = INTP( ht_search( lh, &nums[ i ] ) ) ))
printf( "%d found\n", nums[ i ] ) ;
else
printf( "%d not found\n", nums[ i ] ) ;
iter = ht_iterate( lh , DICT_FROM_START ) ;
while (( ip = INTP( ht_nextobj( lh, iter ) ) ))
printf( "Object = %d\n", *ip ) ;
for ( ip = INTP(ht_minimum( lh )) ; ip ; ip = INTP(ht_successor( lh, ip )) )
printf( "Object = %d\n", *ip ) ;
for ( ip=INTP(ht_maximum( lh )) ; ip ; ip=INTP(ht_predecessor( lh, ip )) )
printf( "Object = %d\n", *ip ) ;
exit( 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);
}
static obj_ptr _div(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKFLOAT(0);
int ct = 0;
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
ct++;
if (NINTP(arg) && NFLOATP(arg))
{
res = MKERROR(MKSTRING("Expected a number in /"), arg);
return res;
}
else if (ct == 1)
{
if (INTP(arg))
FLOAT(res) = (double)INT(arg);
else
FLOAT(res) = FLOAT(arg);
}
else if (INTP(arg))
{
FLOAT(res) /= (double)INT(arg);
}
else if (FLOATP(arg))
{
FLOAT(res) /= FLOAT(arg);
}
}
if (ct == 1)
{
FLOAT(res) = 1 / FLOAT(res);
}
return res;
}
/* 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;
}
static inline SEXP __Rmatalloc(int m, int n, char *type, int init)
{
SEXP RET;
if (strncmp(type, "vec", 1) == 0)
{
PROTECT(RET = allocMatrix(VECSXP, m, n));
}
else if (strncmp(type, "int", 1) == 0)
{
PROTECT(RET = allocMatrix(INTSXP, m, n));
if (init)
memset(INTP(RET), 0, m*n*sizeof(int));
}
else if (strncmp(type, "double", 1) == 0)
{
PROTECT(RET = allocMatrix(REALSXP, m, n));
if (init)
memset(DBLP(RET), 0, m*n*sizeof(double));
}
else if (strncmp(type, "boolean", 1) == 0 || strncmp(type, "logical", 1) == 0)
{
PROTECT(RET = allocMatrix(LGLSXP, m, n));
if (init)
memset(INTP(RET), 0, m*n*sizeof(int));
}
else if (strncmp(type, "str", 1) == 0 || strncmp(type, "char*", 1) == 0)
{
PROTECT(RET = allocMatrix(STRSXP, m, n));
}
else
error("unknown allocation type\n");
UNPROTECT(1);
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;
}
