Return to ox_gsl.c CVS log | Up to [local] / OpenXM / src / ox_gsl |
version 1.6, 2018/04/05 10:50:17 | version 1.16, 2019/10/21 05:37:20 | ||
---|---|---|---|
|
|
||
/* $OpenXM: OpenXM/src/ox_gsl/ox_gsl.c,v 1.5 2018/04/04 01:03:59 takayama Exp $ | /* $OpenXM: OpenXM/src/ox_gsl/ox_gsl.c,v 1.15 2018/06/08 00:03:43 takayama Exp $ | ||
*/ | */ | ||
#include <stdio.h> | #include <stdio.h> | ||
|
|
||
#include <setjmp.h> | #include <setjmp.h> | ||
#include <string.h> | #include <string.h> | ||
#include <unistd.h> | #include <unistd.h> | ||
#include <signal.h> | |||
#include <math.h> | #include <math.h> | ||
#include "ox_gsl.h" | #include "ox_gsl.h" | ||
#include "call_gsl.h" // need only when you bind call_gsl functions. | #include "call_gsl.h" // need only when you bind call_gsl functions. | ||
#include "call_gsl_sf.h" | |||
OXFILE *fd_rw; | OXFILE *fd_rw; | ||
|
|
||
myhandler("get_double: not a double",NULL,0,-1); | myhandler("get_double: not a double",NULL,0,-1); | ||
return(NAN); | return(NAN); | ||
} | } | ||
/* get_double() will be obsolted and will be replaced by cmo2double(c) */ | |||
double cmo2double(cmo *c) | |||
{ | |||
#define mympz(c) (((cmo_zz *)c)->mpz) | |||
if (c == NULL) c = pop(); | |||
if (c->tag == CMO_INT32) { | |||
return( (double) (((cmo_int32 *)c)->i) ); | |||
}else if (c->tag == CMO_IEEE_DOUBLE_FLOAT) { | |||
return (((cmo_double *)c)->d); // see ox_toolkit.h | |||
}else if (c->tag == CMO_ZZ) { | |||
if ((mpz_cmp_si(mympz(c),(long int) 0x7fffffff)>0) || | |||
(mpz_cmp_si(mympz(c),(long int) -0x7fffffff)<0)) { | |||
myhandler("get_double: out of int32",NULL,0,-1); | |||
return(NAN); | |||
} | |||
return( (double) mpz_get_si(((cmo_zz *)c)->mpz)); | |||
}else if (c->tag == CMO_NULL) { | |||
return(0); | |||
}else if (c->tag == CMO_ZERO) { | |||
return(0); | |||
} | |||
myhandler("cmo2double: not a double",NULL,0,-1); | |||
return(NAN); | |||
} | |||
void my_add_double() { | void my_add_double() { | ||
double x,y; | double x,y; | ||
|
|
||
} | } | ||
return(d); | return(d); | ||
} | } | ||
/* get_double_list will be obsolted and will be replaced by cmo2double_list() */ | |||
double *cmo2double_list(int *length,cmo *c) { | |||
cmo *entry; | |||
cell *cellp; | |||
double *d; | |||
int n,i; | |||
if (c == NULL) c = pop(); | |||
if (c->tag != CMO_LIST) { | |||
// make_error2("get_double_list",NULL,0,-1); | |||
*length=-1; return(0); | |||
} | |||
n = *length = list_length((cmo_list *)c); | |||
d = (double *) GC_malloc(sizeof(double)*(*length+1)); | |||
cellp = list_first((cmo_list *)c); | |||
entry = cellp->cmo; | |||
for (i=0; i<n; i++) { | |||
if (Debug) { | |||
printf("entry[%d]=",i); print_cmo(entry); printf("\n"); | |||
} | |||
if (entry->tag == CMO_INT32) { | |||
d[i]=( (double) (((cmo_int32 *)entry)->i) ); | |||
}else if (entry->tag == CMO_IEEE_DOUBLE_FLOAT) { | |||
d[i]=((cmo_double *)entry)->d; | |||
}else if (entry->tag == CMO_ZZ) { | |||
d[i]=( (double) mpz_get_si(((cmo_zz *)entry)->mpz)); | |||
}else if (entry->tag == CMO_NULL) { | |||
d[i]= 0; | |||
}else { | |||
fprintf(stderr,"entries of the list should be int32 or zz or double\n"); | |||
*length = -1; | |||
myhandler("get_double_list",NULL,0,-1); | |||
return(NULL); | |||
} | |||
cellp = list_next(cellp); | |||
entry = cellp->cmo; | |||
} | |||
return(d); | |||
} | |||
void show_double_list() { | void show_double_list() { | ||
int n; | int n; | ||
double *d; | double *d; | ||
|
|
||
return(NULL); | return(NULL); | ||
} | } | ||
cmo_tree *get_tree() { | |||
cmo *c; | |||
c = pop(); | |||
if (c->tag == CMO_TREE) { | |||
return ((cmo_tree *)c); | |||
} | |||
make_error2("cmo_tree is expected",NULL,0,-1); | |||
return(NULL); | |||
} | |||
void print_tree(cmo_tree *c) { | |||
if (c->tag != CMO_TREE) { | |||
printf("Error: argument is not CMO_TREE\n"); | |||
return; | |||
} | |||
print_cmo((cmo *)c); | |||
/* | |||
ox_printf("(name="); print_cmo((cmo *)(c->name)); ox_printf(","); | |||
ox_printf("leaves="); print_cmo((cmo *)(c->leaves)); ox_printf(")"); | |||
*/ | |||
} | |||
void test_ox_eval() { | void test_ox_eval() { | ||
cmo_tree *c; | cmo *c; | ||
double d=0; | double d=0; | ||
pop(); | pop(); | ||
c = get_tree(); | c=pop(); | ||
if (Debug) { | if (Debug) { | ||
ox_printf("cmo_tree *c="); print_tree(c); ox_printf("\n"); | ox_printf("cmo *c="); print_cmo(c); ox_printf("\n"); | ||
} | } | ||
init_dic(); | init_dic(); | ||
register_entry("x",1.25); | register_entry("x",1.25); | ||
if (eval_cmo(c,&d) == 0) make_error2("eval_cmo failed",NULL,0,-1); | if (eval_cmo(c,&d) == 0) myhandler("eval_cmo failed",NULL,0,-1); | ||
push((cmo *)new_cmo_double(d)); | push((cmo *)new_cmo_double(d)); | ||
} | } | ||
|
|
||
push(make_error2("sm_executeFunction, not CMO_STRING",NULL,0,-1)); | push(make_error2("sm_executeFunction, not CMO_STRING",NULL,0,-1)); | ||
return -1; | return -1; | ||
} | } | ||
init_dic(); | |||
// Test functions | // Test functions | ||
if (strcmp(func->s, "add_int32") == 0) { | if (strcmp(func->s, "add_int32") == 0) { | ||
my_add_int32(); | my_add_int32(); | ||
|
|
||
// The following functions are defined in call_gsl.c | // The following functions are defined in call_gsl.c | ||
}else if (strcmp(func->s,"gsl_sf_lngamma_complex_e")==0) { | }else if (strcmp(func->s,"gsl_sf_lngamma_complex_e")==0) { | ||
call_gsl_sf_lngamma_complex_e(); | call_gsl_sf_lngamma_complex_e(); | ||
}else if (strcmp(func->s,"gsl_integration_qags")==0) { | |||
call_gsl_integration_qags(); | |||
}else if (strcmp(func->s,"gsl_monte_plain_integrate")==0) { | |||
call_gsl_monte_plain_miser_vegas_integrate(0); | |||
}else if (strcmp(func->s,"gsl_monte_miser_integrate")==0) { | |||
call_gsl_monte_plain_miser_vegas_integrate(1); | |||
}else if (strcmp(func->s,"gsl_monte_vegas_integrate")==0) { | |||
call_gsl_monte_plain_miser_vegas_integrate(2); | |||
}else if (strcmp(func->s,"gsl_odeiv_step_rk4")==0) { | |||
call_gsl_odeiv_step("rk4"); | |||
}else if (strcmp(func->s,"gsl_sf_gamma_inc")==0) { | |||
call_gsl_sf_gamma_inc(); | |||
}else { | }else { | ||
push(make_error2("sm_executeFunction, unknown function",NULL,0,-1)); | push(make_error2("sm_executeFunction, unknown function",NULL,0,-1)); | ||
return -1; | return -1; | ||
|
|
||
fd_rw = oxf_open(3); | fd_rw = oxf_open(3); | ||
oxf_determine_byteorder_server(fd_rw); | oxf_determine_byteorder_server(fd_rw); | ||
} | } | ||
#if defined(__CYGWIN__) | |||
void *mysignal(int sig,void (*handler)(int m)); | |||
mysignal(SIGUSR1,usr1_handler); | |||
#else | |||
signal(SIGUSR1,usr1_handler); | signal(SIGUSR1,usr1_handler); | ||
#endif | |||
while(1) { | while(1) { | ||
receive(); | receive(); | ||
} | } | ||
return(0); | return(0); | ||
} | |||
cmo *element_of_at(cmo *list,int k) { | |||
int length; | |||
static cmo * saved_list = NULL; | |||
static cmo **dic; | |||
int i; | |||
cell *cellp; | |||
if (list == NULL) { | |||
ox_printf("element_of_at: list is NULL.\n"); | |||
return( (cmo *)NULL); | |||
} | |||
if (list->tag != CMO_LIST) { | |||
ox_printf("element_of_at: list is not list.\n"); | |||
return((cmo *)NULL); | |||
} | |||
length = list_length((cmo_list *)list); | |||
if ((k < 0) || (k >= length)) { | |||
ox_printf("element_of_at: out of bound length=%d, k=%d.\n",length,k); | |||
return((cmo *)NULL); | |||
} | |||
if (list == saved_list) return(dic[k]); | |||
saved_list = list; | |||
dic = (cmo **)GC_malloc(sizeof(cmo *)*(length+1)); | |||
if (dic == NULL) return((cmo *)NULL); // no more memory. | |||
cellp = list_first((cmo_list *)list); | |||
for (i=0; i<length; i++) { | |||
dic[i] = cellp->cmo; | |||
cellp = list_next(cellp); | |||
} | |||
return(dic[k]); | |||
} | |||
int get_length(cmo *c) { | |||
if (c->tag != CMO_LIST) { | |||
return(-1); | |||
} | |||
return(list_length((cmo_list *)c)); | |||
} | } |