numo-linalg 0.0.1

data/ext/numo/linalg/blas/tmpl/rot.c

@@ -0,0 +1,65 @@
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    char *p1, *p2;
+    size_t n;
+    ssize_t s1, s2;
+    rtype  *g;
+
+    INIT_COUNTER(lp,n);
+    INIT_PTR(lp,0,p1,s1);
+    INIT_PTR(lp,1,p2,s2);
+    g = (rtype*)(lp->opt_ptr);
+
+    (*func_p)(n, (dtype*)p1, s1/sizeof(dtype),
+                 (dtype*)p2, s2/sizeof(dtype), g[0], g[1]);
+}
+
+/*<%
+ params = [
+   vec("x",:inplace),
+   vec("y",:inplace),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( x, y, c, s )
+  <%=params%>
+  @param [Float] c
+  @param [Float] s
+  @return [Array<<%=class_name%>,<%=class_name%>>] returns [x,y]
+
+<%=description%>
+
+*/
+static VALUE
+<%=c_func(4)%>(VALUE UNUSED(mod), VALUE x, VALUE y, VALUE c, VALUE s)
+{
+    rtype g[2] = {0,0};
+    narray_t *na1, *na2;
+    ndfunc_arg_in_t ain[2] = {{OVERWRITE,0},{OVERWRITE,0}};
+    ndfunc_t ndf = {<%=c_iter%>, STRIDE_LOOP, 2,0, ain,0};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    if (RTEST(c)) {g[0] = NUM2DBL(c);}
+    if (RTEST(s)) {g[1] = NUM2DBL(s);}
+
+    COPY_OR_CAST_TO(x,cT);
+    COPY_OR_CAST_TO(y,cT);
+    GetNArray(x,na1);
+    GetNArray(y,na2);
+    CHECK_DIM_GE(na1,1);
+    CHECK_DIM_GE(na2,1);
+    CHECK_NON_EMPTY(na1);
+    CHECK_NON_EMPTY(na2);
+    CHECK_SAME_SHAPE(na1,na2);
+
+    na_ndloop3(&ndf, g, 2, x, y);
+
+    return rb_assoc_new(x,y);
+}
+
+#undef func_p

data/ext/numo/linalg/blas/tmpl/rotm.c

@@ -0,0 +1,82 @@
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    char *p1, *p2;
+    size_t n;
+    ssize_t s1, s2;
+    dtype  *g;
+
+    INIT_COUNTER(lp,n);
+    INIT_PTR(lp,0,p1,s1);
+    INIT_PTR(lp,1,p2,s2);
+    g = (dtype*)(lp->opt_ptr);
+
+    (*func_p)(n, (dtype*)p1, s1/sizeof(dtype),
+                 (dtype*)p2, s2/sizeof(dtype), g);
+}
+
+/*<%
+ params = [
+   vec("x",:inplace),
+   vec("y",:inplace),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( x, y, param )
+  <%=params%>
+  @param param [<%=class_name%>]  array of [FLAG,H11,H21,H12,H22]
+  @return [Array<<%=class_name%>,<%=class_name%>>] returns [x,y]
+
+Apply the modified givens transformation, H,
+to the 2 by N matrix (X\*\*T), where \*\*T indicates transpose.
+The elements of X are in (Y\*\*T)
+
+X(LX+I\*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else
+LX = (-INCX)\*N, and similarly for Y using LY and INCY.
+With PARAM(1)=FLAG, H has one of the following forms..
+
+        FLAG=-1.0     FLAG=0.0        FLAG=1.0     FLAG=-2.0
+
+          (H11  H12)    (1.0  H12)    (H11  1.0)    (1.0  0.0)
+        H=(        )    (        )    (        )    (        )
+          (H21  H22),   (H21  1.0),   (-1.0 H22),   (0.0  1.0).
+
+see <%=name.upcase%>G for a description of data storage in param.
+
+ */
+static VALUE
+<%=c_func(3)%>(VALUE UNUSED(mod), VALUE x, VALUE y, VALUE param)
+{
+    dtype *g;
+    narray_t *na1, *na2, *nap;
+    ndfunc_arg_in_t ain[2] = {{OVERWRITE,0},{OVERWRITE,0}};
+    ndfunc_t ndf = {<%=c_iter%>, STRIDE_LOOP, 2,0, ain,0};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    COPY_OR_CAST_TO(x,cT);
+    COPY_OR_CAST_TO(y,cT);
+    GetNArray(x,na1);
+    GetNArray(y,na2);
+    CHECK_DIM_GE(na1,1);
+    CHECK_DIM_GE(na2,1);
+    CHECK_NON_EMPTY(na1);
+    CHECK_NON_EMPTY(na2);
+    CHECK_SAME_SHAPE(na1,na2);
+
+    param = rb_funcall(cT,rb_intern("cast"),1,param);
+    GetNArray(param,nap);
+    CHECK_DIM_EQ(nap,1);
+    CHECK_SIZE_GE(nap,5);
+    g = (dtype*)nary_get_pointer_for_read(param);
+
+    na_ndloop3(&ndf, g, 2, x, y);
+
+    RB_GC_GUARD(param);
+    return rb_assoc_new(x,y);
+}
+
+#undef func_p

data/ext/numo/linalg/blas/tmpl/scal.c

@@ -0,0 +1,69 @@
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+<% if /^(cs|zd)scal/ =~ name %>
+#define scal_t rtype
+<% else %>
+#define scal_t dtype
+<% end %>
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    char *p1;
+    size_t n;
+    ssize_t s1;
+    scal_t *g;
+
+    INIT_COUNTER(lp,n);
+    INIT_PTR(lp,0,p1,s1);
+    g = (scal_t*)(lp->opt_ptr);
+
+  <% if /^[cz]scal/ =~ name %>
+    (*func_p)(n, g, (dtype*)p1, s1/sizeof(dtype));
+  <% else %>
+    (*func_p)(n, *g, (dtype*)p1, s1/sizeof(dtype));
+  <% end %>
+}
+
+/*<%
+ params = [
+   vec("x"),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( a, x )
+  @param [Float]        a  scale factor
+  <%=params%>
+  @return [<%=class_name%>] returns a*x.
+
+<%=description%>
+
+ */
+static VALUE
+<%=c_func(2)%>(VALUE mod, VALUE a, VALUE x)
+{
+    scal_t g[1];
+    narray_t *na1;
+    ndfunc_arg_in_t ain[1] = {{OVERWRITE,0}};
+    ndfunc_t ndf = {<%=c_iter%>, STRIDE_LOOP, 1,0, ain,0};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+  <% if /^(cs|zd)scal/ =~ name %>
+    if (RTEST(a)) {g[0] = NUM2DBL(a);} else {g[0]=1;}
+  <% else %>
+    if (RTEST(a)) {g[0] = m_num_to_data(a);} else {g[0]=m_one;}
+  <% end %>
+    COPY_OR_CAST_TO(x,cT);
+    GetNArray(x,na1);
+    CHECK_DIM_GE(na1,1);
+    CHECK_NON_EMPTY(na1);
+
+    na_ndloop3(&ndf, g, 1, x);
+
+    return x;
+}
+
+#undef func_p
+#undef scal_t

data/ext/numo/linalg/blas/tmpl/sdsdot.c

@@ -0,0 +1,77 @@
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    char *p1, *p2, *p3;
+    size_t n;
+    ssize_t s1, s2;
+    dtype  *g;
+
+    INIT_PTR(lp,0,p1,s1);
+    INIT_PTR(lp,1,p2,s2);
+    p3 = NDL_PTR(lp,2);
+    n  = NDL_SHAPE(lp,0)[0];
+    g  = (dtype*)(lp->opt_ptr);
+
+    *(dtype*)p3 = (*func_p)(n, *g, (dtype*)p1, s1/sizeof(dtype),
+                                   (dtype*)p2, s2/sizeof(dtype));
+}
+
+/*<%
+ params = [
+   vec("sx"),
+   vec("sy",:inplace),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( sx, sy, [sb:0] )
+  <%=params%>
+  @param [Float] sb
+  @return [<%=class_name%>] returns inner product.
+
+  Compute the inner product of two vectors with extended
+  precision accumulation.
+
+  Returns S.P. result with dot product accumulated in D.P.
+  SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
+  where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
+  defined in a similar way using INCY.
+
+ */
+static VALUE
+<%=c_func(-1)%>(int argc, VALUE const argv[], VALUE UNUSED(mod))
+{
+    VALUE     x, y, sb;
+    dtype     g[1];
+    narray_t *na1, *na2;
+    size_t    nx, ny;
+    ndfunc_arg_in_t ain[2] = {{cT,1},{cT,1}};
+    ndfunc_arg_out_t aout[1] = {{cT,0}};
+    ndfunc_t ndf = {<%=c_iter%>, NDF_EXTRACT, 2,1, ain,aout};
+
+    VALUE kw_hash = Qnil;
+    ID kw_table[1] = {id_sb};
+    VALUE opts[1] = {Qundef};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    rb_scan_args(argc, argv, "2:", &x, &y, &kw_hash);
+    rb_get_kwargs(kw_hash, kw_table, 0, 1, opts);
+    sb = option_value(opts[0],Qnil);
+    g[0] = RTEST(sb) ? m_num_to_data(sb) : m_zero;
+
+    GetNArray(x,na1);
+    GetNArray(y,na2);
+    CHECK_DIM_GE(na1,1);
+    CHECK_DIM_GE(na2,1);
+    CHECK_NON_EMPTY(na1);
+    CHECK_NON_EMPTY(na2);
+    nx = na1->shape[na1->ndim-1];
+    ny = na2->shape[na2->ndim-1];
+    CHECK_SIZE_EQ(nx,ny);
+
+    return na_ndloop3(&ndf, g, 2, x, y);
+}
+#undef func_p

data/ext/numo/linalg/blas/tmpl/set_prefix.c

@@ -0,0 +1,16 @@
+static VALUE
+<%=c_func(1)%>(VALUE mod, VALUE prefix)
+{
+    long len;
+
+    if (TYPE(prefix) != T_STRING) {
+        rb_raise(rb_eTypeError,"argument must be string");
+    }
+    if (blas_prefix) {
+        free(blas_prefix);
+    }
+    len = RSTRING_LEN(prefix);
+    blas_prefix = malloc(len+1);
+    strcpy(blas_prefix, StringValueCStr(prefix));
+    return prefix;
+}

data/ext/numo/linalg/blas/tmpl/swap.c

@@ -0,0 +1,57 @@
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    char *p1, *p2;
+    size_t n;
+    ssize_t s1, s2;
+
+    INIT_COUNTER(lp,n);
+    INIT_PTR(lp,0,p1,s1);
+    INIT_PTR(lp,1,p2,s2);
+
+    (*func_p)(n, (dtype*)p1, s1/sizeof(dtype),
+                 (dtype*)p2, s2/sizeof(dtype));
+}
+
+/*<%
+ params = [
+   vec("x"),
+   vec("y"),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( x, y )
+  <%=params%>
+  @return [nil]
+
+<%=description%>
+
+*/
+static VALUE
+<%=c_func(2)%>(VALUE UNUSED(mod), VALUE x, VALUE y)
+{
+    narray_t *na1, *na2;
+    ndfunc_arg_in_t ain[2] = {{OVERWRITE,0},{OVERWRITE,0}};
+    ndfunc_t ndf = {<%=c_iter%>, STRIDE_LOOP, 2,0, ain,0};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    CHECK_NARRAY_TYPE(x,cT);
+    CHECK_NARRAY_TYPE(y,cT);
+    GetNArray(x,na1);
+    GetNArray(y,na2);
+    CHECK_DIM_GE(na1,1);
+    CHECK_DIM_GE(na2,1);
+    CHECK_NON_EMPTY(na1);
+    CHECK_NON_EMPTY(na2);
+    CHECK_SAME_SHAPE(na1,na2);
+
+    na_ndloop(&ndf, 2, x, y);
+
+    return Qnil;
+}
+
+#undef func_p

data/ext/numo/linalg/blas/tmpl/syr.c

@@ -0,0 +1,102 @@
+#define args_t <%=name%>_args_t
+
+typedef struct {
+    enum CBLAS_ORDER order;
+    enum CBLAS_UPLO uplo;
+    rtype alpha;
+} args_t;
+
+#define func_p <%=func_name%>_p
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t *const lp)
+{
+    dtype *a;
+    char *p1;
+    ssize_t s1;
+    args_t *g;
+    blasint n, lda;
+
+    INIT_PTR(lp,0,p1,s1);
+    a = (dtype*)NDL_PTR(lp,1);
+    g = (args_t*)(lp->opt_ptr);
+
+    n = NDL_SHAPE(lp,0)[0];
+    lda = NDL_STEP(lp,1) / sizeof(dtype);
+
+    (*func_p)(g->order, g->uplo, n, g->alpha,
+              (dtype*)p1, s1/sizeof(dtype), a, lda);
+}
+
+/*<%
+ params = [
+   vec("x"),
+   mat("a",:inplace),
+   opt("alpha"),
+   opt("uplo"),
+   opt("order")
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( x, [a, alpha:1, uplo:'U', order:'R'] )
+  <%=params%>
+  @return [<%=class_name%>] return a
+<%=description%>
+
+ */
+static VALUE
+<%=c_func(-1)%>(int argc, VALUE const argv[], VALUE UNUSED(mod))
+{
+    VALUE     ans;
+    VALUE     x, a, alpha;
+    narray_t *na1, *na3;
+    blasint   nx, na;
+    size_t    shape[2];
+    ndfunc_arg_in_t ain[3] = {{cT,1},{OVERWRITE,2},{sym_init,0}};
+    ndfunc_arg_out_t aout[1] = {{cT,2,shape}};
+    ndfunc_t ndf = {<%=c_iter%>, NO_LOOP, 2, 0, ain, aout};
+
+    args_t g;
+    VALUE kw_hash = Qnil;
+    ID kw_table[3] = {id_alpha,id_order,id_uplo};
+    VALUE opts[3] = {Qundef,Qundef,Qundef};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    rb_scan_args(argc, argv, "11:", &x, &a, &kw_hash);
+    rb_get_kwargs(kw_hash, kw_table, 0, 3, opts);
+    alpha   = option_value(opts[0],Qnil);
+    g.alpha = RTEST(alpha) ? NUM2DBL(alpha) : 1;
+    g.order = option_order(opts[1]);
+    g.uplo  = option_uplo(opts[2]);
+
+    GetNArray(x,na1);
+    CHECK_DIM_GE(na1,1);
+    nx = COL_SIZE(na1); // n
+
+    if (a == Qnil) { // c is not given.
+        ndf.nout = 1;
+        ain[1] = ain[2];
+        a = INT2FIX(0);
+        shape[0] = shape[1] = nx;
+    } else {
+        COPY_OR_CAST_TO(a,cT);
+        GetNArray(a,na3);
+        CHECK_DIM_GE(na3,2);
+        CHECK_SQUARE("a",na3);
+        na = COL_SIZE(na3); // n (lda)
+        CHECK_SIZE_EQ(na,nx);
+    }
+
+    ans = na_ndloop3(&ndf, &g, 2, x, a);
+
+    if (ndf.nout == 1) { // a is not given.
+        return ans;
+    } else {
+        return a;
+    }
+}
+
+#undef func_p
+#undef args_t