static VALUE rb_gsl_multifit_ndlinear_calc(int argc, VALUE *argv, VALUE obj)
{
gsl_multifit_ndlinear_workspace *w;
gsl_vector *x = NULL, *c = NULL;
double val;
int argc2;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
if (!rb_obj_is_kind_of(argv[argc-1], cWorkspace)) {
rb_raise(rb_eTypeError,
"Wrong argument type %s (GSL::MultiFit::Ndlinear::Workspace expected)",
rb_class2name(CLASS_OF(argv[argc-1])));
}
Data_Get_Struct(argv[argc-1], gsl_multifit_ndlinear_workspace, w);
argc2 = argc-1;
break;
default:
Data_Get_Struct(obj, gsl_multifit_ndlinear_workspace, w);
argc2 = argc;
}
switch (argc2) {
case 2:
CHECK_VECTOR(argv[0]);
CHECK_VECTOR(argv[1]);
Data_Get_Struct(argv[0], gsl_vector, x);
Data_Get_Struct(argv[1], gsl_vector, c);
break;
default:
rb_raise(rb_eArgError, "Wrong number of arguments.");
}
val = gsl_multifit_ndlinear_calc(x, c, w);
return rb_float_new(val);
}
/**
* arguments:
* - Plm_deriv_array(x) : lmax = w->lmax, two new vectors are created and returned as an array
* - Plm_array(lmax, x) : Two new vectors are created and returned as an array
* - Plm_array(lmax, x, result, deriv) : Same as C alf_Plm_deriv_array()
*/
static VALUE rb_alf_Plm_deriv_array(int argc, VALUE *argv, VALUE obj)
{
alf_workspace *w = NULL;
gsl_vector *res = NULL, *deriv = NULL;
int lmax;
double x;
VALUE ret1, ret2, ary;
Data_Get_Struct(obj, alf_workspace, w);
switch (argc) {
case 1:
x = NUM2DBL(argv[0]);
lmax = w->lmax;
res = gsl_vector_alloc(alf_array_size(lmax));
deriv = gsl_vector_alloc(alf_array_size(lmax));
ret1 = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, res);
ret2 = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, deriv);
break;
case 2:
lmax = FIX2INT(argv[1]);
x = NUM2DBL(argv[1]);
res = gsl_vector_alloc(alf_array_size(lmax));
deriv = gsl_vector_alloc(alf_array_size(lmax));
ret1 = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, res);
ret2 = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, deriv);
break;
case 3:
CHECK_VECTOR(argv[1]);
CHECK_VECTOR(argv[2]);
ret1 = argv[1];
ret2 = argv[2];
lmax = w->lmax;
x = NUM2DBL(argv[0]);
break;
case 4:
lmax = FIX2INT(argv[0]);
x = NUM2DBL(argv[1]);
CHECK_VECTOR(argv[2]);
CHECK_VECTOR(argv[3]);
Data_Get_Struct(argv[2], gsl_vector, res);
Data_Get_Struct(argv[3], gsl_vector, deriv);
if (res->size < alf_array_size(lmax)) {
rb_raise(rb_eRuntimeError, "Vector length is too small. (%d for >= %d\n", (int) res->size,
(int) alf_array_size(lmax));
}
if (deriv->size < alf_array_size(lmax)) {
rb_raise(rb_eRuntimeError, "Vector length is too small. (%d for >= %d\n", (int) res->size,
(int) alf_array_size(lmax));
}
ret1 = argv[2];
ret2 = argv[3];
break;
default:
rb_raise(rb_eArgError, "Wrong number of argumentso (%d for 1-4)\n", argc);
}
alf_Plm_deriv_array(lmax, x, res->data, deriv->data, w);
ary = rb_ary_new2(2);
rb_ary_store(ary, 0, ret1);
rb_ary_store(ary, 1, ret2);
return ary;
}
static VALUE rb_gsl_blas_drotm2(VALUE obj, VALUE xx, VALUE yy, VALUE PP)
{
gsl_vector *x = NULL, *y = NULL, *p = NULL, *xnew = NULL, *ynew = NULL;
int flag = 0, i;
CHECK_VECTOR(xx);
CHECK_VECTOR(yy);
Data_Get_Struct(xx, gsl_vector, x);
Data_Get_Struct(yy, gsl_vector, y);
if (rb_obj_is_kind_of(PP, cgsl_vector)) {
Data_Get_Struct(PP, gsl_vector, p);
} else {
if (TYPE(PP) != T_ARRAY) rb_raise(rb_eTypeError, "wrong argument type %s (Array of Vector expected", rb_class2name(CLASS_OF(PP)));
// p = gsl_vector_alloc(RARRAY(PP)->len);
p = gsl_vector_alloc(RARRAY_LEN(PP));
for (i = 0; i < RARRAY_LEN(PP); i++) {
gsl_vector_set(p, i, rb_ary_entry(PP, i));
}
flag = 1;
}
xnew = gsl_vector_alloc(x->size);
ynew = gsl_vector_alloc(y->size);
gsl_vector_memcpy(xnew, x);
gsl_vector_memcpy(ynew, y);
gsl_blas_drotm(xnew, ynew, p->data);
if (flag == 1) gsl_vector_free(p);
return rb_ary_new3(2, Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, xnew),
Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, ynew));
}
static VALUE rb_gsl_graph_set_xydata(VALUE obj, VALUE xx, VALUE yy)
{
gsl_graph *g = NULL;
Data_Get_Struct(obj, gsl_graph, g);
CHECK_VECTOR(xx); CHECK_VECTOR(yy);
g->xdata = xx;
g->ydata = yy;
return obj;
}
static VALUE rb_gsl_interp_bsearch(int argc, VALUE *argv, VALUE obj)
{
gsl_vector *v = NULL;
double x;
size_t indexl, indexh;
switch (TYPE(obj)) {
case T_MODULE: case T_CLASS: case T_OBJECT:
switch (argc) {
case 2:
CHECK_VECTOR(argv[0]);
Need_Float(argv[1]);
Data_Get_Struct(argv[0], gsl_vector, v);
x = NUM2DBL(argv[1]);
indexl = gsl_vector_get(v, 0);
indexh = gsl_vector_get(v, v->size-1);
break;
case 4:
CHECK_VECTOR(argv[0]);
Need_Float(argv[1]); Need_Float(argv[2]); Need_Float(argv[3]);
Data_Get_Struct(argv[0], gsl_vector, v);
x = NUM2DBL(argv[1]);
indexl = NUM2DBL(argv[2]);
indexh = NUM2DBL(argv[3]);
break;
default:
rb_raise(rb_eArgError, "wrong number of arguments (%d for 2 or 4)", argc);
break;
}
break;
default:
Data_Get_Struct(obj, gsl_vector, v);
switch (argc) {
case 1:
Need_Float(argv[0]);
x = NUM2DBL(argv[0]);
indexl = gsl_vector_get(v, 0);
indexh = gsl_vector_get(v, v->size-1);
break;
case 3:
Need_Float(argv[0]); Need_Float(argv[1]); Need_Float(argv[2]);
x = NUM2DBL(argv[0]);
indexl = NUM2DBL(argv[1]);
indexh = NUM2DBL(argv[2]);
break;
default:
rb_raise(rb_eArgError, "wrong number of arguments (%d for 1 or 3)", argc);
break;
}
break;
}
return INT2FIX(gsl_interp_bsearch(v->data, x, indexl, indexh));
}
static VALUE rb_gsl_blas_drot(VALUE obj, VALUE xx, VALUE yy, VALUE cc, VALUE ss)
{
gsl_vector *x = NULL, *y = NULL;
double c, s;
CHECK_VECTOR(xx);
CHECK_VECTOR(yy);
Need_Float(cc);
Need_Float(ss);
Data_Get_Struct(xx, gsl_vector, x);
Data_Get_Struct(yy, gsl_vector, y);
c = NUM2DBL(cc);
s = NUM2DBL(ss);
gsl_blas_drot(x, y, c, s);
return rb_ary_new3(2, xx, yy);
}
static VALUE rb_gsl_rational_coerce(VALUE obj, VALUE other)
{
gsl_rational *r = NULL;
gsl_poly *p = NULL, *ptmp = NULL;
size_t i;
switch (TYPE(other)) {
case T_FLOAT:
case T_FIXNUM:
p = gsl_vector_alloc(1);
gsl_vector_set(p, 0, NUM2DBL(other));
break;
case T_ARRAY:
p = gsl_vector_alloc(RARRAY_LEN(other));
for (i = 0; i < p->size; i++)
gsl_vector_set(p, i, NUM2DBL(rb_ary_entry(other, i)));
break;
default:
CHECK_VECTOR(other);
Data_Get_Struct(other, gsl_vector, ptmp);
p = make_vector_clone(ptmp);
break;
}
ptmp = gsl_vector_alloc(1);
gsl_vector_set(ptmp, 0, 1.0);
r = gsl_rational_new2(p, ptmp);
return rb_ary_new3(2,
Data_Wrap_Struct(cgsl_rational, gsl_rational_mark, gsl_rational_free, r), obj);
}
static VALUE rb_gsl_bspline_eval(int argc, VALUE *argv, VALUE obj)
{
gsl_bspline_workspace *w;
double x;
gsl_vector *B;
VALUE vB;
Data_Get_Struct(obj, gsl_bspline_workspace, w);
switch (argc) {
case 2:
CHECK_VECTOR(argv[1]);
Data_Get_Struct(argv[1], gsl_vector, B);
vB = argv[1];
x = NUM2DBL(argv[0]);
break;
case 1:
x = NUM2DBL(argv[0]);
B = gsl_vector_alloc(w->nbreak+w->k-2);
vB = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, B);
break;
default:
rb_raise(rb_eArgError, "Wrong number of arguments (%d for 1 or 2)", argc);
}
gsl_bspline_eval(x, B, w);
return vB;
}
/* Take the word before point (or Vabbrev_start_location, if non-nil),
and look it up in OBARRAY, and return the symbol (or zero). This
used to be the default method of searching, with the obvious
limitation that the abbrevs may consist only of word characters.
It is an order of magnitude faster than the proper abbrev_match(),
but then again, vi is an order of magnitude faster than Emacs.
This speed difference should be unnoticeable, though. I have tested
the degenerated cases of thousands of abbrevs being defined, and
abbrev_match() was still fast enough for normal operation. */
static Lisp_Symbol *abbrev_oblookup(struct buffer *buf, Lisp_Object obarray)
{
Bufpos wordstart, wordend;
Bufbyte *word, *p;
Bytecount idx;
Lisp_Object lookup;
CHECK_VECTOR(obarray);
if (!NILP(Vabbrev_start_location)) {
wordstart = get_buffer_pos_char(buf, Vabbrev_start_location,
GB_COERCE_RANGE);
Vabbrev_start_location = Qnil;
#if 0
/* Previously, abbrev-prefix-mark crockishly inserted a dash to
indicate the abbrev start point. It now uses an extent with
a begin glyph so there's no dash to remove. */
if (wordstart != BUF_ZV(buf)
&& BUF_FETCH_CHAR(buf, wordstart) == '-') {
buffer_delete_range(buf, wordstart, wordstart + 1, 0);
}
#endif
wordend = BUF_PT(buf);
} else {
Bufpos point = BUF_PT(buf);
wordstart = scan_words(buf, point, -1);
if (!wordstart)
return 0;
wordend = scan_words(buf, wordstart, 1);
if (!wordend)
return 0;
if (wordend > BUF_ZV(buf))
wordend = BUF_ZV(buf);
if (wordend > point)
wordend = point;
/* Unlike the original function, we allow expansion only after
the abbrev, not preceded by a number of spaces. This is
because of consistency with abbrev_match. */
if (wordend < point)
return 0;
}
if (wordend <= wordstart)
return 0;
p = word = (Bufbyte *) alloca(MAX_EMCHAR_LEN * (wordend - wordstart));
for (idx = wordstart; idx < wordend; idx++) {
Emchar c = BUF_FETCH_CHAR(buf, idx);
if (UPPERCASEP(buf, c))
c = DOWNCASE(buf, c);
p += set_charptr_emchar(p, c);
}
lookup = oblookup(obarray, word, p - word);
if (SYMBOLP(lookup) && !NILP(symbol_value(XSYMBOL(lookup))))
return XSYMBOL(lookup);
else
return NULL;
}
static VALUE rb_gsl_odeiv_evolve_apply(VALUE obj, VALUE cc, VALUE ss, VALUE sss,
VALUE tt, VALUE tt1, VALUE hh, VALUE yy)
{
gsl_odeiv_evolve *e = NULL;
gsl_odeiv_control *c = NULL;
gsl_odeiv_step *s = NULL;
gsl_odeiv_system *sys = NULL;
gsl_vector *y = NULL;
double t, h;
int status;
CHECK_STEP(ss); CHECK_SYSTEM(sss);
CHECK_VECTOR(yy);
Data_Get_Struct(obj, gsl_odeiv_evolve, e);
if (NIL_P(cc)) {
c = NULL;
} else {
CHECK_CONTROL(cc);
Data_Get_Struct(cc, gsl_odeiv_control, c);
}
Data_Get_Struct(ss, gsl_odeiv_step, s);
Data_Get_Struct(sss, gsl_odeiv_system, sys);
Data_Get_Struct(yy, gsl_vector, y);
/* if (TYPE(tt) != T_FLOAT) rb_raise(rb_eTypeError, "argument 4 Float expected");
if (TYPE(hh) != T_FLOAT) rb_raise(rb_eTypeError, "argument 6 Float expected");*/
t = NUM2DBL(tt);
h = NUM2DBL(hh);
status = gsl_odeiv_evolve_apply(e, c, s, sys, &t, NUM2DBL(tt1), &h, y->data);
/* RFLOAT(tt)->value = t;
RFLOAT(hh)->value = h;*/
return rb_ary_new3(3, rb_float_new(t), rb_float_new(h), INT2FIX(status));
}
static VALUE rb_gsl_blas_dscal2(int argc, VALUE *argv, VALUE obj)
{
double a;
gsl_vector *x = NULL, *xnew = NULL;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
if (argc != 2) rb_raise(rb_eArgError, "wrong number of arguments (%d for 2)",
argc);
Need_Float(argv[0]);
CHECK_VECTOR(argv[1]);
a = NUM2DBL(argv[0]);
Data_Get_Struct(argv[1], gsl_vector, x);
break;
default:
Data_Get_Struct(obj, gsl_vector, x);
if (argc != 1) rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
argc);
Need_Float(argv[0]);
a = NUM2DBL(argv[0]);
break;
}
xnew = gsl_vector_alloc(x->size);
gsl_vector_memcpy(xnew, x);
gsl_blas_dscal(a, xnew);
return Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, xnew);
}
static VALUE rb_gsl_blas_dscal(int argc, VALUE *argv, VALUE obj)
{
double a;
gsl_vector *x = NULL;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
if (argc != 2) rb_raise(rb_eArgError, "wrong number of arguments (%d for 2)",
argc);
Need_Float(argv[0]);
CHECK_VECTOR(argv[1]);
// a = RFLOAT(argv[0])->value;
a = NUM2DBL(argv[0]);
Data_Get_Struct(argv[1], gsl_vector, x);
gsl_blas_dscal(a, x);
return argv[1];
break;
default:
if (argc != 1) rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
argc);
Need_Float(argv[0]);
// a = RFLOAT(argv[0])->value;
a = NUM2DBL(argv[0]);
Data_Get_Struct(obj, gsl_vector, x);
gsl_blas_dscal(a, x);
return obj;
break;
}
return Qnil; /* never reach here */
}
static VALUE rb_gsl_blas_daxpy2(int argc, VALUE *argv, VALUE obj)
{
double a;
gsl_vector *x = NULL, *y = NULL, *y2 = NULL;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
get_vector2(argc-1, argv+1, obj, &x, &y);
Need_Float(argv[0]);
// a = RFLOAT(argv[0])->value;
a = NUM2DBL(argv[0]);
break;
default:
Data_Get_Struct(obj, gsl_vector, x);
if (argc != 2) rb_raise(rb_eArgError, "wrong number of arguments (%d for 2)",
argc);
Need_Float(argv[0]);
CHECK_VECTOR(argv[1]);
// a = RFLOAT(argv[0])->value;
a = NUM2DBL(argv[0]);
Data_Get_Struct(argv[1], gsl_vector, y);
break;
}
y2 = gsl_vector_alloc(y->size);
gsl_vector_memcpy(y2, y);
gsl_blas_daxpy(a, x, y2);
return Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, y2);
}
static emacs_value
module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i)
{
MODULE_FUNCTION_BEGIN (module_nil);
Lisp_Object lvec = value_to_lisp (vec);
CHECK_VECTOR (lvec);
CHECK_RANGED_INTEGER (make_number (i), 0, ASIZE (lvec) - 1);
return lisp_to_value (AREF (lvec, i));
}
static ptrdiff_t
module_vec_size (emacs_env *env, emacs_value vec)
{
/* FIXME: Return a sentinel value (e.g., -1) on error. */
MODULE_FUNCTION_BEGIN (0);
Lisp_Object lvec = value_to_lisp (vec);
CHECK_VECTOR (lvec);
return ASIZE (lvec);
}
static VALUE rb_ool_conmin_constraint_set_L(VALUE obj, VALUE vL)
{
ool_conmin_constraint *C;
gsl_vector *L;
CHECK_VECTOR(vL);
Data_Get_Struct(obj, ool_conmin_constraint, C);
Data_Get_Struct(vL, gsl_vector, L);
C->L = L;
return vL;
}
static VALUE rb_ool_conmin_constraint_set_U(VALUE obj, VALUE vU)
{
ool_conmin_constraint *C;
gsl_vector *U;
CHECK_VECTOR(vU);
Data_Get_Struct(obj, ool_conmin_constraint, C);
Data_Get_Struct(vU, gsl_vector, U);
C->U = U;
return vU;
}
static void
module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val)
{
/* FIXME: This function should return bool because it can fail. */
MODULE_FUNCTION_BEGIN ();
Lisp_Object lvec = value_to_lisp (vec);
CHECK_VECTOR (lvec);
CHECK_RANGED_INTEGER (make_number (i), 0, ASIZE (lvec) - 1);
ASET (lvec, i, value_to_lisp (val));
}
static VALUE rb_cqp_data_set_d(VALUE obj, VALUE vv)
{
gsl_cqp_data *d;
gsl_vector *v;
Data_Get_Struct(obj, gsl_cqp_data, d);
CHECK_VECTOR(vv);
Data_Get_Struct(vv, gsl_vector, v);
d->d = v;
return Qtrue;
}
/* singleton */
static VALUE rb_gsl_permute_vector_inverse(VALUE obj, VALUE pp, VALUE vv)
{
gsl_permutation *p = NULL;
gsl_vector *v;
int status;
CHECK_VECTOR(vv);
Data_Get_Struct(pp, gsl_permutation, p);
Data_Get_Struct(vv, gsl_vector, v);
status = gsl_permute_vector_inverse(p, v);
return INT2FIX(status);
}
static VALUE rb_gsl_blas_drot2(VALUE obj, VALUE xx, VALUE yy, VALUE cc, VALUE ss)
{
gsl_vector *x = NULL, *y = NULL, *xnew = NULL, *ynew = NULL;
double c, s;
CHECK_VECTOR(xx);
CHECK_VECTOR(yy);
Need_Float(cc);
Need_Float(ss);
Data_Get_Struct(xx, gsl_vector, x);
Data_Get_Struct(yy, gsl_vector, y);
c = NUM2DBL(cc);
s = NUM2DBL(ss);
xnew = gsl_vector_alloc(x->size);
ynew = gsl_vector_alloc(y->size);
gsl_vector_memcpy(xnew, x);
gsl_vector_memcpy(ynew, y);
gsl_blas_drot(xnew, ynew, c, s);
return rb_ary_new3(2, Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, xnew),
Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, ynew));
}
static VALUE rb_gsl_odeiv_control_hadjust(VALUE obj, VALUE ss, VALUE yy0,
VALUE yyerr, VALUE ddydt, VALUE hh)
{
gsl_odeiv_control *c = NULL;
gsl_odeiv_step *s = NULL;
gsl_vector *y0 = NULL, *yerr = NULL, *dydt = NULL;
double h;
int status;
CHECK_VECTOR(yy0);
CHECK_VECTOR(yyerr);
CHECK_VECTOR(ddydt);
Data_Get_Struct(obj, gsl_odeiv_control, c);
Data_Get_Struct(ss, gsl_odeiv_step, s);
Data_Get_Struct(yy0, gsl_vector, y0);
Data_Get_Struct(yyerr, gsl_vector, yerr);
Data_Get_Struct(ddydt, gsl_vector, dydt);
h = NUM2DBL(hh);
status = gsl_odeiv_control_hadjust(c, s, y0->data, yerr->data,
dydt->data, &h);
return rb_ary_new3(2, rb_float_new(h), INT2FIX(status));
}
static VALUE rb_gsl_odeiv_step_apply(int argc, VALUE *argv, VALUE obj)
{
gsl_odeiv_step *s = NULL;
gsl_odeiv_system *sys = NULL;
gsl_vector *y = NULL, *yerr = NULL;
gsl_vector *vtmp1 = NULL, *vtmp2 = NULL;
double *dydt_in = NULL, *dydt_out = NULL;
double t, h;
switch (argc) {
case 5:
break;
case 7:
if (VECTOR_P(argv[5])) {
Data_Get_Struct(argv[5], gsl_vector, vtmp2);
if (vtmp2) dydt_out = vtmp2->data;
}
/* no break */
case 6:
if (VECTOR_P(argv[4])) {
Data_Get_Struct(argv[4], gsl_vector, vtmp1);
if (vtmp1) dydt_in = vtmp1->data;
}
break;
default:
rb_raise(rb_eArgError, "wrong number of arguments (%d for 5, 6 or 7)", argc);
break;
}
Need_Float(argv[0]); Need_Float(argv[1]);
CHECK_VECTOR(argv[2]); CHECK_VECTOR(argv[3]);
CHECK_SYSTEM(argv[argc-1]);
Data_Get_Struct(obj, gsl_odeiv_step, s);
t = NUM2DBL(argv[0]);
h = NUM2DBL(argv[1]);
Data_Get_Struct(argv[2], gsl_vector, y);
Data_Get_Struct(argv[3], gsl_vector, yerr);
Data_Get_Struct(argv[argc-1], gsl_odeiv_system, sys);
return INT2FIX(gsl_odeiv_step_apply(s, t, h, y->data, yerr->data,
dydt_in, dydt_out, sys));
}
static VALUE rb_gsl_odeiv_control_scaled_new(VALUE klass, VALUE epsabs,
VALUE epsrel,
VALUE ay, VALUE adydt,
VALUE sc, VALUE dd)
{
gsl_odeiv_control *c = NULL;
gsl_vector *v = NULL;
Need_Float(epsabs); Need_Float(epsrel);
Need_Float(ay); Need_Float(adydt);
CHECK_FIXNUM(dd);
CHECK_VECTOR(sc);
Data_Get_Struct(sc, gsl_vector, v);
c = gsl_odeiv_control_scaled_new(NUM2DBL(epsabs), NUM2DBL(epsrel),
NUM2DBL(ay), NUM2DBL(adydt), v->data,
FIX2INT(dd));
return Data_Wrap_Struct(klass, 0, gsl_odeiv_control_free, c);
}
static VALUE rb_gsl_odeiv_solver_apply(VALUE obj, VALUE tt, VALUE tt1, VALUE hh,
VALUE yy)
{
gsl_odeiv_solver *gos = NULL;
gsl_vector *y = NULL;
double t, h;
int status;
CHECK_VECTOR(yy);
Need_Float(tt1);
Data_Get_Struct(obj, gsl_odeiv_solver, gos);
Data_Get_Struct(yy, gsl_vector, y);
/* if (TYPE(tt) != T_FLOAT) rb_raise(rb_eTypeError, "argument 0 Float expected");
if (TYPE(hh) != T_FLOAT) rb_raise(rb_eTypeError, "argument 2 Float expected");*/
t = NUM2DBL(tt);
h = NUM2DBL(hh);
status = gsl_odeiv_evolve_apply(gos->e, gos->c, gos->s,
gos->sys, &t, NUM2DBL(tt1), &h, y->data);
/* RFLOAT(tt)->value = t;
RFLOAT(hh)->value = h;
return INT2FIX(status);*/
return rb_ary_new3(3, rb_float_new(t), rb_float_new(h), INT2FIX(status));
}
static VALUE rb_gsl_bspline_knots(VALUE obj, VALUE b)
{
gsl_bspline_workspace *w;
Data_Get_Struct(obj, gsl_bspline_workspace, w);
#ifdef HAVE_NMATRIX_H
if (NM_IsNMatrix(b)) {
NM_DENSE_STORAGE *nm_bpts;
gsl_vector_view v;
nm_bpts = NM_STORAGE_DENSE(b);
v = gsl_vector_view_array((double*) nm_bpts->elements, NM_DENSE_COUNT(b));
gsl_bspline_knots(&v.vector, w);
return Data_Wrap_Struct(cgsl_vector_view_ro, 0, NULL, w->knots);
}
#endif
gsl_vector *bpts;
CHECK_VECTOR(b);
Data_Get_Struct(b, gsl_vector, bpts);
gsl_bspline_knots(bpts, w);
return Data_Wrap_Struct(cgsl_vector_view_ro, 0, NULL, w->knots);
}
double* get_ptr_double3(VALUE obj, size_t *size, size_t *stride, int *flag)
{
gsl_vector *v;
#ifdef HAVE_NARRAY_H
double *ptr;
struct NARRAY *na;
if (NA_IsNArray(obj)) {
obj = na_change_type(obj, NA_DFLOAT);
GetNArray(obj, na);
ptr = (double *) na->ptr;
*size = na->total;
*stride = 1;
*flag = 1;
return ptr;
}
#endif
CHECK_VECTOR(obj);
Data_Get_Struct(obj, gsl_vector, v);
*size = v->size;
*stride = v->stride;
*flag = 0;
return v->data;
}
/**
* arguments:
* - Plm_array(x) : lmax = w->lmax, A new vector is created
* - Plm_array(x, result) : lmax = w->lmax, the given vector is used
* - Plm_array(lmax, x) : A new vector is created
* - Plm_array(lmax, x, result) : Same as C Plm_array()
* - Plm_array(x, result, deriv) : lmax = w->lmax, calcurate Plm_deriv_array(lmax, x, result, deriv)
* - Plm_array(lmax, x, result, deriv) : Same as C alf_Plm_deriv_array
*/
static VALUE rb_alf_Plm_array(int argc, VALUE *argv, VALUE obj)
{
alf_workspace *w = NULL;
gsl_vector *res = NULL, *deriv = NULL;
int lmax;
double x;
VALUE ret;
Data_Get_Struct(obj, alf_workspace, w);
switch (argc) {
case 1:
x = NUM2DBL(argv[0]);
lmax = w->lmax;
res = gsl_vector_alloc(alf_array_size(lmax));
ret = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, res);
break;
case 2: // Plm_array(x, result) or Plm_array(lmax, x)
if (VECTOR_P(argv[1])) {
x = NUM2DBL(argv[0]);
Data_Get_Struct(argv[1], gsl_vector, res);
lmax = w->lmax;
if (res->size < alf_array_size(lmax)) {
rb_raise(rb_eRuntimeError, "Vector length is too small. (%d for >= %d\n", (int) res->size,
(int) alf_array_size(lmax));
}
ret = argv[1];
} else {
lmax = FIX2INT(argv[0]);
x = NUM2DBL(argv[1]);
res = gsl_vector_alloc(alf_array_size(lmax));
ret = Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, res);
}
break;
case 3: // Plm_array(lmax, x, result) or Plm_array(x, result, deriv)
if (VECTOR_P(argv[1])) {
CHECK_VECTOR(argv[2]);
lmax = w->lmax;
x = NUM2DBL(argv[0]);
Data_Get_Struct(argv[1], gsl_vector, res);
Data_Get_Struct(argv[2], gsl_vector, deriv);
ret = argv[1];
} else {
lmax = FIX2INT(argv[0]);
x = NUM2DBL(argv[1]);
CHECK_VECTOR(argv[2]);
Data_Get_Struct(argv[2], gsl_vector, res);
if (res->size < alf_array_size(lmax)) {
rb_raise(rb_eRuntimeError, "Vector length is too small. (%d for >= %d\n", (int) res->size,
(int) alf_array_size(lmax));
}
ret = argv[2];
}
break;
case 4:
CHECK_VECTOR(argv[2]); CHECK_VECTOR(argv[3])
lmax = FIX2INT(argv[0]);
x = NUM2DBL(argv[1]);
Data_Get_Struct(argv[2], gsl_vector, res);
Data_Get_Struct(argv[3], gsl_vector, deriv);
ret = argv[2];
break;
default:
rb_raise(rb_eArgError, "Wrong number of argumentso (%d for 1-3)\n", argc);
}
if (argc == 4 && deriv != NULL) alf_Plm_deriv_array(lmax, x, res->data, deriv->data, w);
else alf_Plm_array(lmax, x, res->data, w);
return ret;
}
/***** solver *****/
static VALUE rb_gsl_siman_solver_solve(VALUE obj, VALUE rng,
VALUE vx0p, VALUE vefunc,
VALUE vstep, VALUE vmetric, VALUE vprint,
VALUE vparams)
{
gsl_rng *r = NULL;
siman_solver *ss = NULL;
siman_Efunc *efunc = NULL;
siman_step *step = NULL;
siman_metric *metric = NULL;
siman_print *print = NULL;
gsl_vector *vtmp = NULL;
gsl_siman_params_t *params = NULL, ppp;
int flag = 0;
/* Data_Get_Struct(obj, siman_solver, ss);*/
CHECK_VECTOR(vx0p);
Data_Get_Struct(vx0p, gsl_vector, vtmp);
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
ss = gsl_siman_solver_alloc(vtmp->size);
flag = 1;
break;
default:
Data_Get_Struct(obj, siman_solver, ss);
}
if (!rb_obj_is_kind_of(rng, cgsl_rng))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Rng expected)",
rb_class2name(CLASS_OF(rng)));
if (!rb_obj_is_kind_of(vefunc, cgsl_siman_Efunc))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Siman::Efunc expected)",
rb_class2name(CLASS_OF(vefunc)));
if (!rb_obj_is_kind_of(vstep, cgsl_siman_step))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Siman::Step expected)",
rb_class2name(CLASS_OF(vstep)));
if (!rb_obj_is_kind_of(vmetric, cgsl_siman_metric))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Siman::Metric expected)",
rb_class2name(CLASS_OF(vmetric)));
Data_Get_Struct(rng, gsl_rng, r);
Data_Get_Struct(vefunc, siman_Efunc, efunc);
Data_Get_Struct(vstep, siman_step, step);
Data_Get_Struct(vmetric, siman_metric, metric);
if (NIL_P(vprint)) {
ss->proc_print = Qnil;
} else {
if (!rb_obj_is_kind_of(vprint, cgsl_siman_print))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Siman::Print expected)",
rb_class2name(CLASS_OF(vprint)));
Data_Get_Struct(vprint, siman_print, print);
ss->proc_print = print->proc;
}
if (!rb_obj_is_kind_of(vparams, cgsl_siman_params))
rb_raise(rb_eTypeError, "wrong argument type %s (GSL::Siman::Params expected)",
rb_class2name(CLASS_OF(vparams)));
Data_Get_Struct(vparams, gsl_siman_params_t, params);
ss->proc_efunc = efunc->proc;
ss->proc_step = step->proc;
ss->proc_metric = metric->proc;
gsl_vector_memcpy(ss->vx, vtmp);
ppp = *params;
if (NIL_P(vprint)) {
gsl_siman_solve(r, ss, rb_gsl_siman_Efunc_t,
rb_gsl_siman_step_t,
rb_gsl_siman_metric_t,
NULL,
rb_gsl_siman_copy_t,
rb_gsl_siman_copy_construct_t,
rb_gsl_siman_destroy_t, 0,
*params);
} else {
gsl_siman_solve(r, ss, rb_gsl_siman_Efunc_t,
rb_gsl_siman_step_t,
rb_gsl_siman_metric_t,
rb_gsl_siman_print_t,
rb_gsl_siman_copy_t,
rb_gsl_siman_copy_construct_t,
rb_gsl_siman_destroy_t, 0,
*params);
}
gsl_vector_memcpy(vtmp, ss->vx);
if (flag == 1) gsl_siman_solver_free(ss);
return obj;
}
static VALUE rb_gsl_math_eval2(double (*func)(const double, const double), VALUE xx,
VALUE yy)
{
VALUE x, y, ary;
size_t i, j, size;
gsl_vector *v = NULL, *v2 = NULL, *vnew = NULL;
gsl_matrix *m = NULL, *m2 = NULL, *mnew = NULL;
if (CLASS_OF(xx) == rb_cRange) xx = rb_gsl_range2ary(xx);
switch (TYPE(xx)) {
case T_FIXNUM:
case T_BIGNUM:
case T_FLOAT:
Need_Float(yy);
return rb_float_new((*func)(NUM2DBL(xx), NUM2DBL(yy)));
break;
case T_ARRAY:
Check_Type(yy, T_ARRAY);
size = RARRAY_LEN(xx);
// if (size != RARRAY(yy)->len) rb_raise(rb_eRuntimeError, "array sizes are different.");
if ((int) size != RARRAY_LEN(yy)) rb_raise(rb_eRuntimeError, "array sizes are different.");
ary = rb_ary_new2(size);
for (i = 0; i < size; i++) {
x = rb_ary_entry(xx, i);
y = rb_ary_entry(yy, i);
Need_Float(x); Need_Float(y);
// rb_ary_store(ary, i, rb_float_new((*func)(RFLOAT(x)->value, RFLOAT(y)->value)));
rb_ary_store(ary, i, rb_float_new((*func)(NUM2DBL(x), NUM2DBL(y))));
}
return ary;
break;
default:
#ifdef HAVE_NARRAY_H
if (NA_IsNArray(xx)) {
struct NARRAY *nax, *nay;
double *ptr1, *ptr2, *ptr3;
GetNArray(xx, nax);
GetNArray(yy, nay);
ptr1 = (double*) nax->ptr;
ptr2 = (double*) nay->ptr;
size = nax->total;
ary = na_make_object(NA_DFLOAT, nax->rank, nax->shape, CLASS_OF(xx));
ptr3 = NA_PTR_TYPE(ary, double*);
for (i = 0; i < size; i++) ptr3[i] = (*func)(ptr1[i], ptr2[i]);
return ary;
}
#endif
if (VECTOR_P(xx)) {
CHECK_VECTOR(yy);
Data_Get_Struct(xx, gsl_vector, v);
Data_Get_Struct(yy, gsl_vector, v2);
vnew = gsl_vector_alloc(v->size);
for (i = 0; i < v->size; i++) {
gsl_vector_set(vnew, i, (*func)(gsl_vector_get(v, i), gsl_vector_get(v2, i)));
}
return Data_Wrap_Struct(cgsl_vector, 0, gsl_vector_free, vnew);
} else if (MATRIX_P(xx)) {
CHECK_MATRIX(yy);
Data_Get_Struct(xx, gsl_matrix, m);
Data_Get_Struct(yy, gsl_matrix, m2);
mnew = gsl_matrix_alloc(m->size1, m->size2);
for (i = 0; i < m->size1; i++) {
for (j = 0; j < m->size2; j++) {
gsl_matrix_set(mnew, i, j, (*func)(gsl_matrix_get(m, i, j), gsl_matrix_get(m2, i, j)));
}
}
return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, mnew);
} else {
rb_raise(rb_eTypeError,
"wrong argument type %s "
"(Array or Vector or Matrix expected)", rb_class2name(CLASS_OF(xx)));
}
break;
}
/* never reach here */
return Qnil;
}
