ruby-dcl 1.6.2

data/grph2_uwpack.c

@@ -0,0 +1,552 @@
+/*
+ * $Id: p_header,v 1.2 2011-02-23 17:47:10 koshiro Exp $
+ */
+
+#include <stdio.h>
+#include "ruby.h"
+#include "libtinyf2c.h"
+#include "narray.h"
+
+/* for compatibility with ruby 1.6 */
+#ifndef StringValuePtr
+#define StringValuePtr(s) STR2CSTR(s)
+#endif
+
+#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 real */
+/* fnclib */
+extern real rd2r_(real *);
+extern real rr2d_(real *);
+extern real rexp_(real *, integer *, integer *);
+extern real rfpi_(void);
+extern real rmod_(real *, real *);
+/* gnmlib */
+extern real rgnlt_(real *);
+extern real rgnle_(real *);
+extern real rgngt_(real *);
+extern real rgnge_(real *);
+/* rfalib */
+extern real rmax_(real *, integer *, integer *);
+extern real rmin_(real *, integer *, integer *);
+extern real rsum_(real *, integer *, integer *);
+extern real rave_(real *, integer *, integer *);
+extern real rvar_(real *, integer *, integer *);
+extern real rstd_(real *, integer *, integer *);
+extern real rrms_(real *, integer *, integer *);
+extern real ramp_(real *, integer *, integer *);
+/* rfblib */
+extern real rprd_(real *, real *, integer *, integer *, integer *);
+extern real rcov_(real *, real *, integer *, integer *, integer *);
+extern real rcor_(real *, real *, integer *, integer *, integer *);
+
+
+extern VALUE mDCL;
+
+static VALUE
+dcl_uwsgxa(obj, xp, nx)
+    VALUE obj, xp, nx;
+{
+    real *i_xp;
+    integer i_nx;
+
+    if (TYPE(xp) == T_FLOAT) {
+      xp = rb_Array(xp);
+    }
+    /* if ((TYPE(xp) != T_ARRAY) && 
+           (rb_obj_is_kind_of(xp, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+    if ((TYPE(nx) != T_BIGNUM) || (TYPE(nx) != T_FIXNUM)) {
+      nx = rb_funcall(nx, rb_intern("to_i"), 0);
+    }
+
+    i_nx = NUM2INT(nx);
+    i_xp = dcl_obj2crealary(xp);
+
+
+    uwsgxa_(i_xp, &i_nx);
+
+    dcl_freecrealary(i_xp);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgxa(obj)
+    VALUE obj;
+{
+    real *o_xp;
+    integer o_nx;
+    VALUE xp;
+    VALUE nx;
+
+    o_xp= ALLOCA_N(real, (o_nx));
+
+    uwqgxa_(o_xp, &o_nx);
+
+    {int array_shape[1] = {o_nx};
+     xp = dcl_crealary2obj(o_xp, (o_nx), 1, array_shape);
+    }
+    nx = INT2NUM(o_nx);
+
+
+    return rb_ary_new3(2, xp, nx);
+
+}
+
+static VALUE
+dcl_uwsgxb(obj, uxmin, uxmax, nx)
+    VALUE obj, uxmin, uxmax, nx;
+{
+    real i_uxmin;
+    real i_uxmax;
+    integer i_nx;
+
+    if (TYPE(uxmin) != T_FLOAT) {
+      uxmin = rb_funcall(uxmin, rb_intern("to_f"), 0);
+    }
+    if (TYPE(uxmax) != T_FLOAT) {
+      uxmax = rb_funcall(uxmax, rb_intern("to_f"), 0);
+    }
+    if ((TYPE(nx) != T_BIGNUM) || (TYPE(nx) != T_FIXNUM)) {
+      nx = rb_funcall(nx, rb_intern("to_i"), 0);
+    }
+
+    i_uxmin = (real)NUM2DBL(uxmin);
+    i_uxmax = (real)NUM2DBL(uxmax);
+    i_nx = NUM2INT(nx);
+
+
+    uwsgxb_(&i_uxmin, &i_uxmax, &i_nx);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgxb(obj)
+    VALUE obj;
+{
+    real o_uxmin;
+    real o_uxmax;
+    integer o_nx;
+    VALUE uxmin;
+    VALUE uxmax;
+    VALUE nx;
+
+    uwqgxb_(&o_uxmin, &o_uxmax, &o_nx);
+
+    uxmin = rb_float_new((double)o_uxmin);
+    uxmax = rb_float_new((double)o_uxmax);
+    nx = INT2NUM(o_nx);
+
+
+    return rb_ary_new3(3, uxmin, uxmax, nx);
+
+}
+
+static VALUE
+dcl_uwsgxz(obj, lsetx)
+    VALUE obj, lsetx;
+{
+    logical i_lsetx;
+
+    i_lsetx = ((lsetx == Qnil)||(lsetx == Qfalse)) ? FALSE_ : TRUE_;
+
+
+    uwsgxz_(&i_lsetx);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgxz(obj)
+    VALUE obj;
+{
+    logical o_lsetx;
+    VALUE lsetx;
+
+    uwqgxz_(&o_lsetx);
+
+    lsetx = (o_lsetx == FALSE_) ? Qfalse : Qtrue;
+
+
+    return lsetx;
+
+}
+
+static VALUE
+dcl_uwsgya(obj, yp, ny)
+    VALUE obj, yp, ny;
+{
+    real *i_yp;
+    integer i_ny;
+
+    if (TYPE(yp) == T_FLOAT) {
+      yp = rb_Array(yp);
+    }
+    /* if ((TYPE(yp) != T_ARRAY) && 
+           (rb_obj_is_kind_of(yp, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+    if ((TYPE(ny) != T_BIGNUM) || (TYPE(ny) != T_FIXNUM)) {
+      ny = rb_funcall(ny, rb_intern("to_i"), 0);
+    }
+
+    i_ny = NUM2INT(ny);
+    i_yp = dcl_obj2crealary(yp);
+
+
+    uwsgya_(i_yp, &i_ny);
+
+    dcl_freecrealary(i_yp);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgya(obj)
+    VALUE obj;
+{
+    real *o_yp;
+    integer o_ny;
+    VALUE yp;
+    VALUE ny;
+
+    o_yp= ALLOCA_N(real, (o_ny));
+
+    uwqgya_(o_yp, &o_ny);
+
+    {int array_shape[1] = {o_ny};
+     yp = dcl_crealary2obj(o_yp, (o_ny), 1, array_shape);
+    }
+    ny = INT2NUM(o_ny);
+
+
+    return rb_ary_new3(2, yp, ny);
+
+}
+
+static VALUE
+dcl_uwsgyb(obj, uymin, uymax, ny)
+    VALUE obj, uymin, uymax, ny;
+{
+    real i_uymin;
+    real i_uymax;
+    integer i_ny;
+
+    if (TYPE(uymin) != T_FLOAT) {
+      uymin = rb_funcall(uymin, rb_intern("to_f"), 0);
+    }
+    if (TYPE(uymax) != T_FLOAT) {
+      uymax = rb_funcall(uymax, rb_intern("to_f"), 0);
+    }
+    if ((TYPE(ny) != T_BIGNUM) || (TYPE(ny) != T_FIXNUM)) {
+      ny = rb_funcall(ny, rb_intern("to_i"), 0);
+    }
+
+    i_uymin = (real)NUM2DBL(uymin);
+    i_uymax = (real)NUM2DBL(uymax);
+    i_ny = NUM2INT(ny);
+
+
+    uwsgyb_(&i_uymin, &i_uymax, &i_ny);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgyb(obj)
+    VALUE obj;
+{
+    real o_uymin;
+    real o_uymax;
+    integer o_ny;
+    VALUE uymin;
+    VALUE uymax;
+    VALUE ny;
+
+    uwqgyb_(&o_uymin, &o_uymax, &o_ny);
+
+    uymin = rb_float_new((double)o_uymin);
+    uymax = rb_float_new((double)o_uymax);
+    ny = INT2NUM(o_ny);
+
+
+    return rb_ary_new3(3, uymin, uymax, ny);
+
+}
+
+static VALUE
+dcl_uwsgyz(obj, lsety)
+    VALUE obj, lsety;
+{
+    logical i_lsety;
+
+    i_lsety = ((lsety == Qnil)||(lsety == Qfalse)) ? FALSE_ : TRUE_;
+
+
+    uwsgyz_(&i_lsety);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgyz(obj)
+    VALUE obj;
+{
+    logical o_lsety;
+    VALUE lsety;
+
+    uwqgyz_(&o_lsety);
+
+    lsety = (o_lsety == FALSE_) ? Qfalse : Qtrue;
+
+
+    return lsety;
+
+}
+
+static VALUE
+dcl_uwqgxi(obj, ux)
+    VALUE obj, ux;
+{
+    real i_ux;
+    integer o_iux;
+    real o_frac;
+    VALUE iux;
+    VALUE frac;
+
+    if (TYPE(ux) != T_FLOAT) {
+      ux = rb_funcall(ux, rb_intern("to_f"), 0);
+    }
+
+    i_ux = (real)NUM2DBL(ux);
+
+
+    uwqgxi_(&i_ux, &o_iux, &o_frac);
+
+    iux = INT2NUM(o_iux);
+    frac = rb_float_new((double)o_frac);
+
+
+    return rb_ary_new3(2, iux, frac);
+
+}
+
+static VALUE
+dcl_uwigxi(obj)
+    VALUE obj;
+{
+    uwigxi_();
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_uwqgyi(obj, uy)
+    VALUE obj, uy;
+{
+    real i_uy;
+    integer o_iuy;
+    real o_frac;
+    VALUE iuy;
+    VALUE frac;
+
+    if (TYPE(uy) != T_FLOAT) {
+      uy = rb_funcall(uy, rb_intern("to_f"), 0);
+    }
+
+    i_uy = (real)NUM2DBL(uy);
+
+
+    uwqgyi_(&i_uy, &o_iuy, &o_frac);
+
+    iuy = INT2NUM(o_iuy);
+    frac = rb_float_new((double)o_frac);
+
+
+    return rb_ary_new3(2, iuy, frac);
+
+}
+
+static VALUE
+dcl_uwigyi(obj)
+    VALUE obj;
+{
+    uwigyi_();
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_ruwgx(obj, ix)
+    VALUE obj, ix;
+{
+    integer i_ix;
+    real o_rtn_val;
+    VALUE rtn_val;
+
+    if ((TYPE(ix) != T_BIGNUM) || (TYPE(ix) != T_FIXNUM)) {
+      ix = rb_funcall(ix, rb_intern("to_i"), 0);
+    }
+
+    i_ix = NUM2INT(ix);
+
+
+    o_rtn_val = ruwgx_(&i_ix);
+
+    rtn_val = rb_float_new((double)o_rtn_val);
+
+
+    return rtn_val;
+
+}
+
+static VALUE
+dcl_ruwgy(obj, iy)
+    VALUE obj, iy;
+{
+    integer i_iy;
+    real o_rtn_val;
+    VALUE rtn_val;
+
+    if ((TYPE(iy) != T_BIGNUM) || (TYPE(iy) != T_FIXNUM)) {
+      iy = rb_funcall(iy, rb_intern("to_i"), 0);
+    }
+
+    i_iy = NUM2INT(iy);
+
+
+    o_rtn_val = ruwgy_(&i_iy);
+
+    rtn_val = rb_float_new((double)o_rtn_val);
+
+
+    return rtn_val;
+
+}
+
+static VALUE
+dcl_iuwgx(obj, ux)
+    VALUE obj, ux;
+{
+    real i_ux;
+    integer o_rtn_val;
+    VALUE rtn_val;
+
+    if (TYPE(ux) != T_FLOAT) {
+      ux = rb_funcall(ux, rb_intern("to_f"), 0);
+    }
+
+    i_ux = (real)NUM2DBL(ux);
+
+
+    o_rtn_val = iuwgx_(&i_ux);
+
+    rtn_val = INT2NUM(o_rtn_val);
+
+
+    return rtn_val;
+
+}
+
+static VALUE
+dcl_iuwgy(obj, uy)
+    VALUE obj, uy;
+{
+    real i_uy;
+    integer o_rtn_val;
+    VALUE rtn_val;
+
+    if (TYPE(uy) != T_FLOAT) {
+      uy = rb_funcall(uy, rb_intern("to_f"), 0);
+    }
+
+    i_uy = (real)NUM2DBL(uy);
+
+
+    o_rtn_val = iuwgy_(&i_uy);
+
+    rtn_val = INT2NUM(o_rtn_val);
+
+
+    return rtn_val;
+
+}
+
+static VALUE
+dcl_uwdflt(obj, nx, ny)
+    VALUE obj, nx, ny;
+{
+    integer i_nx;
+    integer i_ny;
+
+    if ((TYPE(nx) != T_BIGNUM) || (TYPE(nx) != T_FIXNUM)) {
+      nx = rb_funcall(nx, rb_intern("to_i"), 0);
+    }
+    if ((TYPE(ny) != T_BIGNUM) || (TYPE(ny) != T_FIXNUM)) {
+      ny = rb_funcall(ny, rb_intern("to_i"), 0);
+    }
+
+    i_nx = NUM2INT(nx);
+    i_ny = NUM2INT(ny);
+
+
+    uwdflt_(&i_nx, &i_ny);
+
+    return Qnil;
+
+}
+void
+init_grph2_uwpack(mDCL)
+VALUE mDCL;
+{
+    rb_define_module_function(mDCL, "uwsgxa", dcl_uwsgxa, 2);
+    rb_define_module_function(mDCL, "uwqgxa", dcl_uwqgxa, 0);
+    rb_define_module_function(mDCL, "uwsgxb", dcl_uwsgxb, 3);
+    rb_define_module_function(mDCL, "uwqgxb", dcl_uwqgxb, 0);
+    rb_define_module_function(mDCL, "uwsgxz", dcl_uwsgxz, 1);
+    rb_define_module_function(mDCL, "uwqgxz", dcl_uwqgxz, 0);
+    rb_define_module_function(mDCL, "uwsgya", dcl_uwsgya, 2);
+    rb_define_module_function(mDCL, "uwqgya", dcl_uwqgya, 0);
+    rb_define_module_function(mDCL, "uwsgyb", dcl_uwsgyb, 3);
+    rb_define_module_function(mDCL, "uwqgyb", dcl_uwqgyb, 0);
+    rb_define_module_function(mDCL, "uwsgyz", dcl_uwsgyz, 1);
+    rb_define_module_function(mDCL, "uwqgyz", dcl_uwqgyz, 0);
+    rb_define_module_function(mDCL, "uwqgxi", dcl_uwqgxi, 1);
+    rb_define_module_function(mDCL, "uwigxi", dcl_uwigxi, 0);
+    rb_define_module_function(mDCL, "uwqgyi", dcl_uwqgyi, 1);
+    rb_define_module_function(mDCL, "uwigyi", dcl_uwigyi, 0);
+    rb_define_module_function(mDCL, "ruwgx", dcl_ruwgx, 1);
+    rb_define_module_function(mDCL, "ruwgy", dcl_ruwgy, 1);
+    rb_define_module_function(mDCL, "iuwgx", dcl_iuwgx, 1);
+    rb_define_module_function(mDCL, "iuwgy", dcl_iuwgy, 1);
+    rb_define_module_function(mDCL, "uwdflt", dcl_uwdflt, 2);
+}