ruby-dcl 1.6.2

data/math1_gt2dlib.c

@@ -0,0 +1,514 @@
+/*
+ * $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;
+
+#if DCLVER >= 530
+
+static VALUE
+dcl_g2fbli(obj, p, q, z00, z10, z01, z11)
+    VALUE obj, p, q, z00, z10, z01, z11;
+{
+    real i_p;
+    real i_q;
+    real i_z00;
+    real i_z10;
+    real i_z01;
+    real i_z11;
+    real o_z;
+    VALUE z;
+
+    if (TYPE(p) != T_FLOAT) {
+      p = rb_funcall(p, rb_intern("to_f"), 0);
+    }
+    if (TYPE(q) != T_FLOAT) {
+      q = rb_funcall(q, rb_intern("to_f"), 0);
+    }
+    if (TYPE(z00) != T_FLOAT) {
+      z00 = rb_funcall(z00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(z10) != T_FLOAT) {
+      z10 = rb_funcall(z10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(z01) != T_FLOAT) {
+      z01 = rb_funcall(z01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(z11) != T_FLOAT) {
+      z11 = rb_funcall(z11, rb_intern("to_f"), 0);
+    }
+
+    i_p = (real)NUM2DBL(p);
+    i_q = (real)NUM2DBL(q);
+    i_z00 = (real)NUM2DBL(z00);
+    i_z10 = (real)NUM2DBL(z10);
+    i_z01 = (real)NUM2DBL(z01);
+    i_z11 = (real)NUM2DBL(z11);
+
+
+    g2fbli_(&i_p, &i_q, &i_z00, &i_z10, &i_z01, &i_z11, &o_z);
+
+    z = rb_float_new((double)o_z);
+
+
+    return z;
+
+}
+
+static VALUE
+dcl_g2fbl2(obj, p, q, x00, x10, x01, x11, y00, y10, y01, y11)
+    VALUE obj, p, q, x00, x10, x01, x11, y00, y10, y01, y11;
+{
+    real i_p;
+    real i_q;
+    real i_x00;
+    real i_x10;
+    real i_x01;
+    real i_x11;
+    real i_y00;
+    real i_y10;
+    real i_y01;
+    real i_y11;
+    real o_x;
+    real o_y;
+    VALUE x;
+    VALUE y;
+
+    if (TYPE(p) != T_FLOAT) {
+      p = rb_funcall(p, rb_intern("to_f"), 0);
+    }
+    if (TYPE(q) != T_FLOAT) {
+      q = rb_funcall(q, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x00) != T_FLOAT) {
+      x00 = rb_funcall(x00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x10) != T_FLOAT) {
+      x10 = rb_funcall(x10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x01) != T_FLOAT) {
+      x01 = rb_funcall(x01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x11) != T_FLOAT) {
+      x11 = rb_funcall(x11, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y00) != T_FLOAT) {
+      y00 = rb_funcall(y00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y10) != T_FLOAT) {
+      y10 = rb_funcall(y10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y01) != T_FLOAT) {
+      y01 = rb_funcall(y01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y11) != T_FLOAT) {
+      y11 = rb_funcall(y11, rb_intern("to_f"), 0);
+    }
+
+    i_p = (real)NUM2DBL(p);
+    i_q = (real)NUM2DBL(q);
+    i_x00 = (real)NUM2DBL(x00);
+    i_x10 = (real)NUM2DBL(x10);
+    i_x01 = (real)NUM2DBL(x01);
+    i_x11 = (real)NUM2DBL(x11);
+    i_y00 = (real)NUM2DBL(y00);
+    i_y10 = (real)NUM2DBL(y10);
+    i_y01 = (real)NUM2DBL(y01);
+    i_y11 = (real)NUM2DBL(y11);
+
+
+    g2fbl2_(&i_p, &i_q, &i_x00, &i_x10, &i_x01, &i_x11, &i_y00, &i_y10, &i_y01, &i_y11, &o_x, &o_y);
+
+    x = rb_float_new((double)o_x);
+    y = rb_float_new((double)o_y);
+
+
+    return rb_ary_new3(2, x, y);
+
+}
+
+static VALUE
+dcl_g2ibl2(obj, x, y, x00, x10, x01, x11, y00, y10, y01, y11)
+    VALUE obj, x, y, x00, x10, x01, x11, y00, y10, y01, y11;
+{
+    real i_x;
+    real i_y;
+    real i_x00;
+    real i_x10;
+    real i_x01;
+    real i_x11;
+    real i_y00;
+    real i_y10;
+    real i_y01;
+    real i_y11;
+    real o_p;
+    real o_q;
+    VALUE p;
+    VALUE q;
+
+    if (TYPE(x) != T_FLOAT) {
+      x = rb_funcall(x, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y) != T_FLOAT) {
+      y = rb_funcall(y, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x00) != T_FLOAT) {
+      x00 = rb_funcall(x00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x10) != T_FLOAT) {
+      x10 = rb_funcall(x10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x01) != T_FLOAT) {
+      x01 = rb_funcall(x01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(x11) != T_FLOAT) {
+      x11 = rb_funcall(x11, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y00) != T_FLOAT) {
+      y00 = rb_funcall(y00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y10) != T_FLOAT) {
+      y10 = rb_funcall(y10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y01) != T_FLOAT) {
+      y01 = rb_funcall(y01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(y11) != T_FLOAT) {
+      y11 = rb_funcall(y11, rb_intern("to_f"), 0);
+    }
+
+    i_x = (real)NUM2DBL(x);
+    i_y = (real)NUM2DBL(y);
+    i_x00 = (real)NUM2DBL(x00);
+    i_x10 = (real)NUM2DBL(x10);
+    i_x01 = (real)NUM2DBL(x01);
+    i_x11 = (real)NUM2DBL(x11);
+    i_y00 = (real)NUM2DBL(y00);
+    i_y10 = (real)NUM2DBL(y10);
+    i_y01 = (real)NUM2DBL(y01);
+    i_y11 = (real)NUM2DBL(y11);
+
+
+    g2ibl2_(&i_x, &i_y, &i_x00, &i_x10, &i_x01, &i_x11, &i_y00, &i_y10, &i_y01, &i_y11, &o_p, &o_q);
+
+    p = rb_float_new((double)o_p);
+    q = rb_float_new((double)o_q);
+
+
+    return rb_ary_new3(2, p, q);
+
+}
+
+static VALUE
+dcl_g2fctr(obj, ux, uy)
+    VALUE obj, ux, uy;
+{
+    real i_ux;
+    real i_uy;
+    real o_cx;
+    real o_cy;
+    VALUE cx;
+    VALUE cy;
+
+    if (TYPE(ux) != T_FLOAT) {
+      ux = rb_funcall(ux, rb_intern("to_f"), 0);
+    }
+    if (TYPE(uy) != T_FLOAT) {
+      uy = rb_funcall(uy, rb_intern("to_f"), 0);
+    }
+
+    i_ux = (real)NUM2DBL(ux);
+    i_uy = (real)NUM2DBL(uy);
+
+
+    g2fctr_(&i_ux, &i_uy, &o_cx, &o_cy);
+
+    cx = rb_float_new((double)o_cx);
+    cy = rb_float_new((double)o_cy);
+
+
+    return rb_ary_new3(2, cx, cy);
+
+}
+
+static VALUE
+dcl_g2ictr(obj, cx, cy)
+    VALUE obj, cx, cy;
+{
+    real i_cx;
+    real i_cy;
+    real o_ux;
+    real o_uy;
+    VALUE ux;
+    VALUE uy;
+
+    if (TYPE(cx) != T_FLOAT) {
+      cx = rb_funcall(cx, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy) != T_FLOAT) {
+      cy = rb_funcall(cy, rb_intern("to_f"), 0);
+    }
+
+    i_cx = (real)NUM2DBL(cx);
+    i_cy = (real)NUM2DBL(cy);
+
+
+    g2ictr_(&i_cx, &i_cy, &o_ux, &o_uy);
+
+    ux = rb_float_new((double)o_ux);
+    uy = rb_float_new((double)o_uy);
+
+
+    return rb_ary_new3(2, ux, uy);
+
+}
+
+static VALUE
+dcl_g2qcti(obj)
+    VALUE obj;
+{
+    logical o_lini;
+    VALUE lini;
+
+    g2qcti_(&o_lini);
+
+    lini = (o_lini == FALSE_) ? Qfalse : Qtrue;
+
+
+    return lini;
+
+}
+
+static VALUE
+dcl_g2qctm(obj)
+    VALUE obj;
+{
+    real o_cxmine;
+    real o_cxmaxe;
+    real o_cymine;
+    real o_cymaxe;
+    VALUE cxmine;
+    VALUE cxmaxe;
+    VALUE cymine;
+    VALUE cymaxe;
+
+    g2qctm_(&o_cxmine, &o_cxmaxe, &o_cymine, &o_cymaxe);
+
+    cxmine = rb_float_new((double)o_cxmine);
+    cxmaxe = rb_float_new((double)o_cxmaxe);
+    cymine = rb_float_new((double)o_cymine);
+    cymaxe = rb_float_new((double)o_cymaxe);
+
+
+    return rb_ary_new3(4, cxmine, cxmaxe, cymine, cymaxe);
+
+}
+
+static VALUE
+dcl_g2sctr(obj, nx, ny, uxa, uya, cxa, cya)
+    VALUE obj, nx, ny, uxa, uya, cxa, cya;
+{
+    integer i_nx;
+    integer i_ny;
+    real *i_uxa;
+    real *i_uya;
+    real *i_cxa;
+    real *i_cya;
+
+    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);
+    }
+    if (TYPE(uxa) == T_FLOAT) {
+      uxa = rb_Array(uxa);
+    }
+    /* if ((TYPE(uxa) != T_ARRAY) && 
+           (rb_obj_is_kind_of(uxa, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+    if (TYPE(uya) == T_FLOAT) {
+      uya = rb_Array(uya);
+    }
+    /* if ((TYPE(uya) != T_ARRAY) && 
+           (rb_obj_is_kind_of(uya, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+    if (TYPE(cxa) == T_FLOAT) {
+      cxa = rb_Array(cxa);
+    }
+    /* if ((TYPE(cxa) != T_ARRAY) && 
+           (rb_obj_is_kind_of(cxa, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+    if (TYPE(cya) == T_FLOAT) {
+      cya = rb_Array(cya);
+    }
+    /* if ((TYPE(cya) != T_ARRAY) && 
+           (rb_obj_is_kind_of(cya, cNArray) != Qtrue)) {
+         rb_raise(rb_eTypeError, "invalid type");
+       }  -- no check since obj2c*ary will do that */
+
+    i_nx = NUM2INT(nx);
+    i_ny = NUM2INT(ny);
+    i_uxa = dcl_obj2crealary(uxa);
+    i_uya = dcl_obj2crealary(uya);
+    i_cxa = dcl_obj2crealary(cxa);
+    i_cya = dcl_obj2crealary(cya);
+
+
+    g2sctr_(&i_nx, &i_ny, i_uxa, i_uya, i_cxa, i_cya);
+
+    dcl_freecrealary(i_uxa);
+    dcl_freecrealary(i_uya);
+    dcl_freecrealary(i_cxa);
+    dcl_freecrealary(i_cya);
+
+    return Qnil;
+
+}
+
+static VALUE
+dcl_lg2inq(obj, cx, cy, cx00, cx10, cx01, cx11, cy00, cy10, cy01, cy11)
+    VALUE obj, cx, cy, cx00, cx10, cx01, cx11, cy00, cy10, cy01, cy11;
+{
+    real i_cx;
+    real i_cy;
+    real i_cx00;
+    real i_cx10;
+    real i_cx01;
+    real i_cx11;
+    real i_cy00;
+    real i_cy10;
+    real i_cy01;
+    real i_cy11;
+    logical o_rtn_val;
+    VALUE rtn_val;
+
+    if (TYPE(cx) != T_FLOAT) {
+      cx = rb_funcall(cx, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy) != T_FLOAT) {
+      cy = rb_funcall(cy, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cx00) != T_FLOAT) {
+      cx00 = rb_funcall(cx00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cx10) != T_FLOAT) {
+      cx10 = rb_funcall(cx10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cx01) != T_FLOAT) {
+      cx01 = rb_funcall(cx01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cx11) != T_FLOAT) {
+      cx11 = rb_funcall(cx11, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy00) != T_FLOAT) {
+      cy00 = rb_funcall(cy00, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy10) != T_FLOAT) {
+      cy10 = rb_funcall(cy10, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy01) != T_FLOAT) {
+      cy01 = rb_funcall(cy01, rb_intern("to_f"), 0);
+    }
+    if (TYPE(cy11) != T_FLOAT) {
+      cy11 = rb_funcall(cy11, rb_intern("to_f"), 0);
+    }
+
+    i_cx = (real)NUM2DBL(cx);
+    i_cy = (real)NUM2DBL(cy);
+    i_cx00 = (real)NUM2DBL(cx00);
+    i_cx10 = (real)NUM2DBL(cx10);
+    i_cx01 = (real)NUM2DBL(cx01);
+    i_cx11 = (real)NUM2DBL(cx11);
+    i_cy00 = (real)NUM2DBL(cy00);
+    i_cy10 = (real)NUM2DBL(cy10);
+    i_cy01 = (real)NUM2DBL(cy01);
+    i_cy11 = (real)NUM2DBL(cy11);
+
+
+    o_rtn_val = lg2inq_(&i_cx, &i_cy, &i_cx00, &i_cx10, &i_cx01, &i_cx11, &i_cy00, &i_cy10, &i_cy01, &i_cy11);
+
+    rtn_val = (o_rtn_val == FALSE_) ? Qfalse : Qtrue;
+
+
+    return rtn_val;
+
+}
+
+#endif
+void
+init_math1_gt2dlib(mDCL)
+VALUE mDCL;
+{
+#if DCLVER >= 530
+    rb_define_module_function(mDCL, "g2fbli", dcl_g2fbli, 6);
+    rb_define_module_function(mDCL, "g2fbl2", dcl_g2fbl2, 10);
+    rb_define_module_function(mDCL, "g2ibl2", dcl_g2ibl2, 10);
+    rb_define_module_function(mDCL, "g2fctr", dcl_g2fctr, 2);
+    rb_define_module_function(mDCL, "g2ictr", dcl_g2ictr, 2);
+    rb_define_module_function(mDCL, "g2qcti", dcl_g2qcti, 0);
+    rb_define_module_function(mDCL, "g2qctm", dcl_g2qctm, 0);
+    rb_define_module_function(mDCL, "g2sctr", dcl_g2sctr, 6);
+    rb_define_module_function(mDCL, "lg2inq", dcl_lg2inq, 10);
+#endif
+}