/* * $Id: p_header,v 1.4 2000/11/27 01:57:01 keiko Exp $ */ #include #include "ruby.h" #include "libtinyf2c.h" #include "narray.h" #define DFLT_SIZE 32 extern char *dcl_obj2ccharary(VALUE, int, int); extern integer *dcl_obj2cintegerary(VALUE); extern real *dcl_obj2crealary(VALUE); extern complex *dcl_obj2ccomplexary(VALUE); extern logical *dcl_obj2clogicalary(VALUE); extern VALUE dcl_ccharary2obj(char *, int, int); extern VALUE dcl_cintegerary2obj(integer *, int, int, int *); extern VALUE dcl_crealary2obj(real *, int, int, int *); extern VALUE dcl_ccomplexary2obj(complex *, int, char *); extern VALUE dcl_clogicalary2obj(logical *, int, int, int *); extern void dcl_freeccharary(char *); extern void dcl_freecintegerary(integer *); extern void dcl_freecrealary(real *); extern void dcl_freeccomplexary(complex *); extern void dcl_freeclogicalary(logical *); /* for functions which return doublereal */ /* fnclib */ extern doublereal rd2r_(real *); extern doublereal rr2d_(real *); extern doublereal rexp_(real *, integer *, integer *); extern doublereal rfpi_(void); extern doublereal rmod_(real *, real *); /* gnmlib */ extern doublereal rgnlt_(real *); extern doublereal rgnle_(real *); extern doublereal rgngt_(real *); extern doublereal rgnge_(real *); /* rfalib */ extern doublereal rmax_(real *, integer *, integer *); extern doublereal rmin_(real *, integer *, integer *); extern doublereal rsum_(real *, integer *, integer *); extern doublereal rave_(real *, integer *, integer *); extern doublereal rvar_(real *, integer *, integer *); extern doublereal rstd_(real *, integer *, integer *); extern doublereal rrms_(real *, integer *, integer *); extern doublereal ramp_(real *, integer *, integer *); /* rfblib */ extern doublereal rprd_(real *, real *, integer *, integer *, integer *); extern doublereal rcov_(real *, real *, integer *, integer *, integer *); extern doublereal rcor_(real *, real *, integer *, integer *, integer *); extern VALUE mDCL; static VALUE dcl_cfftb(obj, n, c, wsave) VALUE obj, n, c, wsave; { integer i_n; real *io_c; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(c) == T_FLOAT) { c = rb_Array(c); } /* if ((TYPE(c) != T_ARRAY) && (rb_obj_is_kind_of(c, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_c = dcl_obj2crealary(c); i_wsave = dcl_obj2crealary(wsave); cfftb_(&i_n, io_c, i_wsave); {int array_shape[1] = {2*i_n}; c = dcl_crealary2obj(io_c, (2*i_n), 1, array_shape); } dcl_freecrealary(io_c); dcl_freecrealary(i_wsave); return c; } static VALUE dcl_cfftf(obj, n, c, wsave) VALUE obj, n, c, wsave; { integer i_n; real *io_c; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(c) == T_FLOAT) { c = rb_Array(c); } /* if ((TYPE(c) != T_ARRAY) && (rb_obj_is_kind_of(c, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_c = dcl_obj2crealary(c); i_wsave = dcl_obj2crealary(wsave); cfftf_(&i_n, io_c, i_wsave); {int array_shape[1] = {2*i_n}; c = dcl_crealary2obj(io_c, (2*i_n), 1, array_shape); } dcl_freecrealary(io_c); dcl_freecrealary(i_wsave); return c; } static VALUE dcl_cffti(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (4*i_n+15)); cffti_(&i_n, o_wsave); {int array_shape[1] = {4*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (4*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_cosqb(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); cosqb_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_cosqf(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); cosqf_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_cosqi(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (3*i_n+15)); cosqi_(&i_n, o_wsave); {int array_shape[1] = {3*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (3*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_cost(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); cost_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_costi(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (3*i_n+15)); costi_(&i_n, o_wsave); {int array_shape[1] = {3*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (3*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_ezfftb(obj, n, azero, a, b, wsave) VALUE obj, n, azero, a, b, wsave; { integer i_n; real *o_r; real i_azero; real *i_a; real *i_b; real *i_wsave; VALUE r; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(azero) != T_FLOAT) { azero = rb_funcall(azero, rb_intern("to_f"), 0); } if (TYPE(a) == T_FLOAT) { a = rb_Array(a); } /* if ((TYPE(a) != T_ARRAY) && (rb_obj_is_kind_of(a, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(b) == T_FLOAT) { b = rb_Array(b); } /* if ((TYPE(b) != T_ARRAY) && (rb_obj_is_kind_of(b, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); i_azero = (real)NUM2DBL(azero); i_a = dcl_obj2crealary(a); i_b = dcl_obj2crealary(b); i_wsave = dcl_obj2crealary(wsave); o_r= ALLOCA_N(real, (i_n)); ezfftb_(&i_n, o_r, &i_azero, i_a, i_b, i_wsave); {int array_shape[1] = {i_n}; r = dcl_crealary2obj(o_r, (i_n), 1, array_shape); } dcl_freecrealary(i_a); dcl_freecrealary(i_b); dcl_freecrealary(i_wsave); return r; } static VALUE dcl_ezfftf(obj, n, r, wsave) VALUE obj, n, r, wsave; { integer i_n; real *i_r; real o_azero; real *o_a; real *o_b; real *i_wsave; VALUE azero; VALUE a; VALUE b; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(r) == T_FLOAT) { r = rb_Array(r); } /* if ((TYPE(r) != T_ARRAY) && (rb_obj_is_kind_of(r, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); i_r = dcl_obj2crealary(r); i_wsave = dcl_obj2crealary(wsave); o_a= ALLOCA_N(real, (i_n/2)); o_b= ALLOCA_N(real, (i_n/2)); ezfftf_(&i_n, i_r, &o_azero, o_a, o_b, i_wsave); azero = rb_float_new((double)o_azero); {int array_shape[1] = {i_n/2}; a = dcl_crealary2obj(o_a, (i_n/2), 1, array_shape); } {int array_shape[1] = {i_n/2}; b = dcl_crealary2obj(o_b, (i_n/2), 1, array_shape); } dcl_freecrealary(i_r); dcl_freecrealary(i_wsave); return rb_ary_new3(3, azero, a, b); } static VALUE dcl_ezffti(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (3*i_n+15)); ezffti_(&i_n, o_wsave); {int array_shape[1] = {3*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (3*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_rfftb(obj, n, r, wsave) VALUE obj, n, r, wsave; { integer i_n; real *io_r; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(r) == T_FLOAT) { r = rb_Array(r); } /* if ((TYPE(r) != T_ARRAY) && (rb_obj_is_kind_of(r, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_r = dcl_obj2crealary(r); i_wsave = dcl_obj2crealary(wsave); rfftb_(&i_n, io_r, i_wsave); {int array_shape[1] = {i_n}; r = dcl_crealary2obj(io_r, (i_n), 1, array_shape); } dcl_freecrealary(io_r); dcl_freecrealary(i_wsave); return r; } static VALUE dcl_rfftf(obj, n, r, wsave) VALUE obj, n, r, wsave; { integer i_n; real *io_r; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(r) == T_FLOAT) { r = rb_Array(r); } /* if ((TYPE(r) != T_ARRAY) && (rb_obj_is_kind_of(r, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_r = dcl_obj2crealary(r); i_wsave = dcl_obj2crealary(wsave); rfftf_(&i_n, io_r, i_wsave); {int array_shape[1] = {i_n}; r = dcl_crealary2obj(io_r, (i_n), 1, array_shape); } dcl_freecrealary(io_r); dcl_freecrealary(i_wsave); return r; } static VALUE dcl_rffti(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (2*i_n+15)); rffti_(&i_n, o_wsave); {int array_shape[1] = {2*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (2*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_sinqb(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); sinqb_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_sinqf(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); sinqf_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_sinqi(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (3*i_n+15)); sinqi_(&i_n, o_wsave); {int array_shape[1] = {3*i_n+15}; wsave = dcl_crealary2obj(o_wsave, (3*i_n+15), 1, array_shape); } return wsave; } static VALUE dcl_sint(obj, n, x, wsave) VALUE obj, n, x, wsave; { integer i_n; real *io_x; real *i_wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } if (TYPE(x) == T_FLOAT) { x = rb_Array(x); } /* if ((TYPE(x) != T_ARRAY) && (rb_obj_is_kind_of(x, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ if (TYPE(wsave) == T_FLOAT) { wsave = rb_Array(wsave); } /* if ((TYPE(wsave) != T_ARRAY) && (rb_obj_is_kind_of(wsave, cNArray) != Qtrue)) { rb_raise(rb_eTypeError, "invalid type"); } -- no check since obj2c*ary will do that */ i_n = NUM2INT(n); io_x = dcl_obj2crealary(x); i_wsave = dcl_obj2crealary(wsave); sint_(&i_n, io_x, i_wsave); {int array_shape[1] = {i_n}; x = dcl_crealary2obj(io_x, (i_n), 1, array_shape); } dcl_freecrealary(io_x); dcl_freecrealary(i_wsave); return x; } static VALUE dcl_sinti(obj, n) VALUE obj, n; { integer i_n; real *o_wsave; VALUE wsave; if ((TYPE(n) != T_BIGNUM) || (TYPE(n) != T_FIXNUM)) { n = rb_funcall(n, rb_intern("to_i"), 0); } i_n = NUM2INT(n); o_wsave= ALLOCA_N(real, (2*i_n+i_n/2+15)); sinti_(&i_n, o_wsave); {int array_shape[1] = {2*i_n+i_n/2+15}; wsave = dcl_crealary2obj(o_wsave, (2*i_n+i_n/2+15), 1, array_shape); } return wsave; } void init_math2_fftlib(mDCL) VALUE mDCL; { rb_define_module_function(mDCL, "cfftb", dcl_cfftb, 3); rb_define_module_function(mDCL, "cfftf", dcl_cfftf, 3); rb_define_module_function(mDCL, "cffti", dcl_cffti, 1); rb_define_module_function(mDCL, "cosqb", dcl_cosqb, 3); rb_define_module_function(mDCL, "cosqf", dcl_cosqf, 3); rb_define_module_function(mDCL, "cosqi", dcl_cosqi, 1); rb_define_module_function(mDCL, "cost", dcl_cost, 3); rb_define_module_function(mDCL, "costi", dcl_costi, 1); rb_define_module_function(mDCL, "ezfftb", dcl_ezfftb, 5); rb_define_module_function(mDCL, "ezfftf", dcl_ezfftf, 3); rb_define_module_function(mDCL, "ezffti", dcl_ezffti, 1); rb_define_module_function(mDCL, "rfftb", dcl_rfftb, 3); rb_define_module_function(mDCL, "rfftf", dcl_rfftf, 3); rb_define_module_function(mDCL, "rffti", dcl_rffti, 1); rb_define_module_function(mDCL, "sinqb", dcl_sinqb, 3); rb_define_module_function(mDCL, "sinqf", dcl_sinqf, 3); rb_define_module_function(mDCL, "sinqi", dcl_sinqi, 1); rb_define_module_function(mDCL, "sint", dcl_sint, 3); rb_define_module_function(mDCL, "sinti", dcl_sinti, 1); }