numo-linalg 0.0.1

data/ext/numo/linalg/lapack/numo_lapack.h

@@ -0,0 +1,42 @@
+#define lapack_complex_float scomplex
+#define lapack_complex_double dcomplex
+#include "lapacke.h"
+#include "lapacke_t.h"
+#include "../numo_linalg.h"
+
+typedef int blasint;
+
+#define option_value numo_lapacke_option_value
+extern int numo_lapacke_option_value(VALUE value, VALUE default_value);
+
+#define option_order numo_lapacke_option_order
+extern int numo_lapacke_option_order(VALUE order);
+
+#define option_job numo_lapacke_option_job
+extern char numo_lapacke_option_job(VALUE job, char true_char, char false_char);
+
+#define option_trans numo_lapacke_option_trans
+extern char numo_lapacke_option_trans(VALUE trans);
+
+#define option_uplo numo_lapacke_option_uplo
+extern char numo_lapacke_option_uplo(VALUE uplo);
+
+#define option_diag numo_lapacke_option_diag
+extern char numo_lapacke_option_diag(VALUE diag);
+
+#define option_side numo_lapacke_option_side
+extern char numo_lapacke_option_side(VALUE side);
+
+#define check_func numo_lapacke_check_func
+extern void numo_lapacke_check_func(void **func, const char *name);
+
+#define CHECK_ERROR(info)                                           \
+    { if ((info)<0) {                                               \
+            rb_raise(eLapackError,"LAPACK error, info=%d",(info)); \
+        }}
+
+#define SWAP_IFCOL(order,a,b)                                           \
+    { if ((order)==LAPACK_COL_MAJOR) {tmp=(a);(a)=(b);(b)=tmp;} }
+
+#define CHECK_FUNC(fptr, fname) \
+    { if ((fptr)==0) { check_func((void*)(&(fptr)),fname); } }

data/ext/numo/linalg/lapack/tmpl/def_c.c

@@ -0,0 +1,3 @@
+#include "numo/types/scomplex.h"
+#define CZ 1
+#define IS_COMPLEX CZ

data/ext/numo/linalg/lapack/tmpl/def_d.c

@@ -0,0 +1,7 @@
+#include "numo/types/dfloat.h"
+#define CZ 0
+#define IS_COMPLEX CZ
+
+#ifndef m_real
+#define m_real(x) (x)
+#endif

data/ext/numo/linalg/lapack/tmpl/def_s.c

@@ -0,0 +1,7 @@
+#include "numo/types/sfloat.h"
+#define CZ 0
+#define IS_COMPLEX CZ
+
+#ifndef m_real
+#define m_real(x) (x)
+#endif

data/ext/numo/linalg/lapack/tmpl/def_z.c

@@ -0,0 +1,3 @@
+#include "numo/types/dcomplex.h"
+#define CZ 1
+#define IS_COMPLEX CZ

data/ext/numo/linalg/lapack/tmpl/fact.c

@@ -0,0 +1,179 @@
+/*<%
+ has_uplo = (/^.(sy|he|po)/ =~ name)
+ has_jpvt = (/geqp3/ =~ name)
+ has_tau  = (/q/ =~ name || /tzrzf/ =~ name)
+%>*/
+<% %>
+#define UPLO <%= has_uplo ? "1":"0" %>
+#define JPVT <%= has_jpvt ? "1":"0" %>
+#define TAU  <%= has_tau ? "1":"0" %>
+#define args_t <%=func_name%>_args_t
+#define func_p <%=func_name%>_p
+
+typedef struct {
+    int order;
+    char uplo;
+} args_t;
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t * const lp)
+{
+    dtype *a;
+#if JPVT
+    int   *pv;
+#endif
+#if TAU
+    dtype *tau;
+#endif
+    int   *info;
+    int    m, n, lda, tmp;
+    args_t *g;
+
+    a = (dtype*)NDL_PTR(lp,0);
+#if JPVT
+    pv = (int*)NDL_PTR(lp,1);
+#endif
+#if TAU
+    tau = (dtype*)NDL_PTR(lp,1+JPVT);
+#endif
+    info = (int*)NDL_PTR(lp,1+JPVT+TAU);
+    g = (args_t*)(lp->opt_ptr);
+
+    m = NDL_SHAPE(lp,0)[0];
+    n = NDL_SHAPE(lp,0)[1];
+    SWAP_IFCOL(g->order,m,n);
+#if UPLO
+    n = min_(m,n);
+#endif
+    lda = NDL_STEP(lp,0) / sizeof(dtype);
+
+    //printf("order=%d m=%d n=%d lda=%d \n",g->order,m,n,lda);
+
+    /*<%
+    func_args = [   "g->order",
+      has_uplo    ? "g->uplo" : "m",
+                    "n, a, lda",
+      has_jpvt   && "pv",
+      has_tau    && "tau",
+    ].select{|x| x}.join(", ")
+    %>*/
+    *info = (*func_p)(<%=func_args%>);
+    CHECK_ERROR(*info);
+}
+
+/*<%
+ args_v = [
+   "a",
+   has_jpvt && "jpvt",
+ ].select{|x| x}.join(", ")
+
+ args_opt = [
+   has_uplo && "uplo:'U'",
+   "order:'R'",
+ ].select{|x| x}.join(", ")
+
+ params = [
+   mat("a",:inplace),
+   has_uplo && opt("uplo"),
+   opt("order"),
+ ].select{|x| x}.join("\n  ")
+
+ return_type = [
+   class_name,
+   has_jpvt && "Numo::Int",
+   has_tau && class_name,
+   "Integer"
+ ].select{|x| x}.join(", ")
+
+ return_name = [
+   "a",
+   has_jpvt && "jpvt",
+   has_tau && "tau",
+   "info"
+ ].select{|x| x}.join(", ")
+%>
+  @overload <%=name%>(<%=args_v%>, [<%=args_opt%>])
+  <%=params%>
+  @return [[<%=return_name%>]] Array<<%=return_type%>>
+<%=outparam(return_name)%>
+
+<%=description%>
+
+*/
+static VALUE
+<%=c_func(-1)%>(int argc, VALUE const argv[], VALUE UNUSED(mod))
+{
+    VALUE a, ans;
+    int   m, n, tmp;
+    narray_t *na1;
+#if JPVT
+    VALUE jpvt;
+#endif
+    /*<%
+    ain = [       "{OVERWRITE,2}",
+      has_jpvt && "{OVERWRITE,1}",
+    ].select{|x| x}.join(",")
+    aout = [
+      has_tau  && "{cT,1,shape_tau}",
+                  "{cInt,0}",
+    ].select{|x| x}.join(",")
+    %>*/
+#if TAU
+    size_t shape_tau[1];
+#endif
+    ndfunc_arg_in_t ain[1+JPVT] = {<%=ain%>};
+    ndfunc_arg_out_t aout[1+TAU] = {<%=aout%>};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT,
+                    1+JPVT, TAU+1, ain,aout};
+
+    args_t g = {0,1};
+    VALUE opts[2] = {Qundef,Qundef};
+    VALUE kw_hash = Qnil;
+    ID kw_table[2] = {id_order,id_uplo};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+#if JPVT
+    rb_scan_args(argc, argv, "2:", &a, &jpvt, &kw_hash);
+#else
+    rb_scan_args(argc, argv, "1:", &a, &kw_hash);
+#endif
+    rb_get_kwargs(kw_hash, kw_table, 0, 1+UPLO, opts);
+    g.order = option_order(opts[0]);
+#if UPLO
+    g.uplo = option_uplo(opts[1]);
+#endif
+
+    COPY_OR_CAST_TO(a,cT);
+    GetNArray(a, na1);
+    CHECK_DIM_GE(na1, 2);
+    m = ROW_SIZE(na1);
+    n = COL_SIZE(na1);
+    SWAP_IFCOL(g.order,m,n);
+#if TAU
+    shape_tau[0] = min_(m,n);
+#endif
+
+#if JPVT
+    COPY_OR_CAST_TO(jpvt,cInt);
+    ans = na_ndloop3(&ndf, &g, 2, a, jpvt);
+    rb_ary_concat(rb_ary_assoc(a,jpvt), ans);
+    return ans;
+#else
+    ans = na_ndloop3(&ndf, &g, 1, a);
+#if TAU == 0
+    return rb_assoc_new(a, ans);
+#else
+    rb_ary_unshift(ans, a);
+    return ans;
+#endif
+#endif
+}
+
+#undef args_t
+#undef func_p
+#undef UPLO
+#undef JPVT
+#undef TAU

data/ext/numo/linalg/lapack/tmpl/geev.c

@@ -0,0 +1,123 @@
+#define args_t <%=func_name%>_args_t
+#define func_p <%=func_name%>_p
+
+typedef struct {
+    int order;
+    char jobvl, jobvr;
+} args_t;
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t * const lp)
+{
+    dtype *a, *vl, *vr;
+#if IS_COMPLEX
+    dtype *w;
+#else
+    dtype *wr, *wi;
+#endif
+    int   *info;
+    int    n, lda, ldvl, ldvr;
+    args_t *g;
+
+    a = (dtype*)NDL_PTR(lp,0);
+#if IS_COMPLEX
+    w = (dtype*)NDL_PTR(lp,1);
+#else
+    wr = (dtype*)NDL_PTR(lp,1);
+    wi = (dtype*)NDL_PTR(lp,2);
+#endif
+    vl = (dtype*)NDL_PTR(lp,3-CZ);
+    vr = (dtype*)NDL_PTR(lp,4-CZ);
+    info = (int*)NDL_PTR(lp,5-CZ);
+    g = (args_t*)(lp->opt_ptr);
+
+    n = NDL_SHAPE(lp,0)[1];
+    lda = NDL_STEP(lp,0) / sizeof(dtype);
+    ldvl = NDL_STEP(lp,3-CZ) / sizeof(dtype);
+    if (ldvl == 0) { ldvl = n; } // jobvt == 'N'
+    ldvr = NDL_STEP(lp,4-CZ) / sizeof(dtype);
+    if (ldvr == 0) { ldvr = n; } // jobvt == 'N'
+
+    //printf("order=%d jobvl=%c jobvr=%c n=%d lda=%d ldvl=%d ldvr=%d\n",g->order,g->jobvl, g->jobvr, n, lda,ldvl,ldvr);
+
+    /*<% func_args = [
+      "g->order, g->jobvl, g->jobvr, n, a, lda",
+      is_complex ? "w" : "wr, wi",
+      "vl, ldvl, vr, ldvr"
+    ].join(",") %>*/
+    *info = (*func_p)(<%=func_args%>);
+    CHECK_ERROR(*info);
+}
+
+/*<%
+ tp = class_name
+ return_type = ([tp]*(is_complex ? 3 : 4) + ["Integer"]).join(", ")
+ return_name = (is_complex ? "w,":"wr, wi,") + " vl, vr, info"
+ params = [
+   mat("a",:inplace),
+   jobe("jobvl"),
+   jobe("jobvr"),
+   opt("order"),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>( a,, [jobvl:'V', jobvr:'V', order:'R'] )
+  <%=params%>
+  @return [[<%=return_name%>]] Array<<%=return_type%>>
+<%=outparam(return_name)%>
+
+<%=description%>
+
+*/
+static VALUE
+<%=c_func(-1)%>(int argc, VALUE const argv[], VALUE UNUSED(mod))
+{
+    VALUE a, ans;
+    int   m, n;
+    narray_t *na1;
+    /*<%
+    aout = [
+      "{cT,1,shape}", !is_complex ? "{cT,1,shape}":nil,
+      "{cT,2,shape},{cT,2,shape},{cInt,0}"
+    ].compact.join(",")
+    %>*/
+    size_t shape[2];
+    ndfunc_arg_in_t ain[1] = {{OVERWRITE,2}};
+    ndfunc_arg_out_t aout[5-CZ] = {<%=aout%>};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT, 1, 5-CZ, ain, aout};
+
+    args_t g = {0,0,0};
+    VALUE opts[3] = {Qundef,Qundef,Qundef};
+    VALUE kw_hash = Qnil;
+    ID kw_table[3] = {id_order,id_jobvl,id_jobvr};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    rb_scan_args(argc, argv, "1:", &a, &kw_hash);
+    rb_get_kwargs(kw_hash, kw_table, 0, 3, opts);
+    g.order = option_order(opts[0]);
+    g.jobvl = option_job(opts[1],'V','N');
+    g.jobvr = option_job(opts[2],'V','N');
+
+    COPY_OR_CAST_TO(a,cT);
+    GetNArray(a, na1);
+    CHECK_DIM_GE(na1, 2);
+    m = ROW_SIZE(na1);
+    n = COL_SIZE(na1);
+    if (m != n) {
+        rb_raise(nary_eShapeError,"matrix must be square");
+    }
+    shape[0] = shape[1] = n;
+    if (g.jobvl=='N') { aout[2-CZ].dim = 0; }
+    if (g.jobvr=='N') { aout[3-CZ].dim = 0; }
+
+    ans = na_ndloop3(&ndf, &g, 1, a);
+
+    if (aout[3-CZ].dim == 0) { RARRAY_ASET(ans,3-CZ,Qnil); }
+    if (aout[2-CZ].dim == 0) { RARRAY_ASET(ans,2-CZ,Qnil); }
+    return ans;
+}
+
+#undef args_t
+#undef func_p

data/ext/numo/linalg/lapack/tmpl/gels.c

@@ -0,0 +1,232 @@
+/*<%
+ is_lss = (/gels(s|d|y)/ =~ name)
+ is_lsd = (/gelsd/ =~ name)
+ is_lsy = (/gelsy/ =~ name)
+%>*/
+<% %>
+#define LSS <%=is_lss ? "1":"0"%>
+#define LSD <%=is_lsd ? "1":"0"%>
+#define LSY <%=is_lsy ? "1":"0"%>
+#define args_t <%=func_name%>_args_t
+#define func_p <%=func_name%>_p
+
+typedef struct {
+    int   order;
+    char  trans;
+    rtype rcond;
+} args_t;
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t * const lp)
+{
+    dtype *a, *b;
+    int   *info;
+    int    m, n, nb, nrhs, lda, ldb, tmp;
+    args_t *g;
+#if LSS
+    <% out_t = is_lsy ? "int" : "rtype" %>
+    <%=out_t%> *s; // or jpvt
+    int   *rank;
+#endif
+
+    a = (dtype*)NDL_PTR(lp,0);
+    b = (dtype*)NDL_PTR(lp,1);
+#if LSS
+    s = (<%=out_t%>*)NDL_PTR(lp,2);
+    rank = (int*)NDL_PTR(lp,3);
+#endif
+    info = (int*)NDL_PTR(lp,2+LSS*2);
+    g = (args_t*)(lp->opt_ptr);
+
+    m = NDL_SHAPE(lp,0)[0];
+    n = NDL_SHAPE(lp,0)[1];
+    SWAP_IFCOL(g->order,m,n);
+    lda = NDL_STEP(lp,0) / sizeof(dtype);
+
+    if (lp->args[1].ndim == 1) {
+        nrhs = 1;
+        nb = NDL_SHAPE(lp,1)[0];
+        ldb = (g->order==LAPACK_COL_MAJOR) ? nb : 1;
+    } else {
+        nb = NDL_SHAPE(lp,1)[0];
+        nrhs = NDL_SHAPE(lp,1)[1];
+        ldb = nrhs;
+        SWAP_IFCOL(g->order,nb,nrhs);
+    }
+
+    //printf("order=%d trans=%c m=%d n=%d nb=%d nrhs=%d lda=%d ldb=%d\n",g->order,g->trans,m,n,nb,nrhs,lda,ldb);
+
+#if LSS
+    *info = (*func_p)(g->order, m, n, nrhs, a, lda, b, ldb, s, g->rcond, rank);
+#else
+    *info = (*func_p)(g->order, g->trans, m, n, nrhs, a, lda, b, ldb);
+#endif
+    CHECK_ERROR(*info);
+}
+
+/*
+<%
+ tp = class_name
+ iary = "Numo::Int"
+ iscal = "Integer"
+ if is_lsy
+   a = "a, b, jpvt, rcond:-1, order:'R'"
+   t = [tp,tp,iary,iscal,iscal]
+   n = "a, b, jpvt, rank, info"
+ elsif is_lsd
+   a = "a, b, rcond:-1, order:'R'"
+   t = [tp,tp,iscal,iscal]
+   n = "b, s, rank, info"
+ elsif is_lss
+   a = "a, b, rcond:-1, order:'R'"
+   t = [tp,tp,tp,iscal,iscal]
+   n = "a, b, s, rank, info"
+ else
+   a = "a, b, trans:'N', order:'R'"
+   t = [tp,tp,iscal]
+   n = "a, b, info"
+ end
+ return_type = t.join(", ")
+ return_name = n
+ args_v = a
+ params = [
+   !is_lsd && mat("a",:inplace),
+              mat("b",:inplace),
+   is_lsy  && mat("jpvt",type:iary),
+   is_lss  && "@param [Float] rcond "+
+     " RCOND is used to determine the effective rank of A."+
+     " Singular values S(i) <= RCOND*S(1) are treated as zero."+
+     " If RCOND < 0, machine precision is used instead.",
+   opt("order"),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>(<%=args_v%>)
+  <%=params%>
+  @return [[<%=return_name%>]] Array<<%=return_type%>>
+<%=outparam(return_name)%>
+
+<%=description%>
+
+*/
+static VALUE
+<%=c_func(-1)%>(int argc, VALUE const argv[], VALUE UNUSED(mod))
+{
+    VALUE a, b, ans;
+    int   m, n, nb, nrhs, tmp;
+    int   max_mn;
+    narray_t *na1, *na2;
+#if LSY
+    narray_t *na3;
+    VALUE jpvt;
+#endif
+#if LSS
+    size_t shape_s[1];
+#endif
+    /*<%
+      ain = [
+        "{OVERWRITE,2},{OVERWRITE,2}", is_lss ? "{cInt,1}":nil,
+      ].compact.join(",")
+      aout = [
+        is_lss ? "{cT,1,shape_s},{cInt,0}":nil, "{cInt,0}",
+      ].compact.join(",")
+    %>*/
+    ndfunc_arg_in_t ain[2+LSS] = {<%=ain%>};
+    ndfunc_arg_out_t aout[1+LSS*2] = {<%=aout%>};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT, 2, 1+LSS*2, ain, aout};
+
+    args_t g;
+    VALUE opts[3] = {Qundef,Qundef,Qundef};
+    ID kw_table[3] = {id_order,id_trans,id_rcond};
+    VALUE kw_hash = Qnil;
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+#if LSY
+    rb_scan_args(argc, argv, "3:", &a, &b, &jpvt, &kw_hash);
+#else
+    rb_scan_args(argc, argv, "2:", &a, &b, &kw_hash);
+#endif
+    rb_get_kwargs(kw_hash, kw_table, 0, 3, opts);
+    g.order = option_order(opts[0]);
+#if LSS
+    g.rcond = NUM2DBL(option_value(opts[2],DBL2NUM(-1)));
+#else
+    g.trans = option_trans(opts[1]);
+#endif
+
+    //A is DOUBLE PRECISION array, dimension (LDA,N)
+    //On entry, the M-by-N matrix A.
+    COPY_OR_CAST_TO(a,cT);
+    GetNArray(a, na1);
+    CHECK_DIM_GE(na1, 2);
+
+    //B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+    //B is M-by-NRHS if TRANS = 'N'
+    //     N-by-NRHS if TRANS = 'T'
+    COPY_OR_CAST_TO(b,cT);
+    GetNArray(b, na2);
+    CHECK_DIM_GE(na2, 1);
+
+    //The number of rows of the matrix A.
+    m = ROW_SIZE(na1);
+    //The number of columns of the matrix A.
+    n = COL_SIZE(na1);
+    max_mn = (m > n) ? m : n;
+    SWAP_IFCOL(g.order,m,n);
+
+#if LSY
+    ndf.nin++;
+    ndf.nout--;
+    ndf.aout++;
+    COPY_OR_CAST_TO(jpvt,cInt);
+    GetNArray(jpvt, na3);
+    CHECK_DIM_GE(na3, 1);
+    { int jpvt_sz = COL_SIZE(na3);
+      CHECK_INT_EQ("jpvt_size",jpvt_sz,"n",n);
+    }
+#elif LSS
+    shape_s[0] = (m < n) ? m : n;
+#endif
+
+    //The number of columns of the matrix B.
+    if (na2->ndim == 1) {
+        ain[1].dim = 1; // reduce dimension
+        nb = COL_SIZE(na2);
+        nrhs = 1;
+    } else {
+        //The number of rows of the matrix B.
+        nb = ROW_SIZE(na2);
+        nrhs = COL_SIZE(na2);
+        SWAP_IFCOL(g.order,nb,nrhs);
+    }
+    if (nb < max_mn) {
+        rb_raise(nary_eShapeError,
+                 "ldb should be >= max(m,n): ldb=%d m=%d n=%d",nb,m,n);
+    }
+
+    // ndloop
+#if LSY
+    ans = na_ndloop3(&ndf, &g, 3, a, b, jpvt);
+#else
+    ans = na_ndloop3(&ndf, &g, 2, a, b);
+#endif
+
+    // return
+#if LSY
+    return rb_ary_concat(rb_ary_new3(3,a,b,jpvt),ans);
+#elif LSD
+    rb_ary_unshift(ans,b); return ans;
+#elif LSS
+    return rb_ary_concat(rb_ary_new3(2,a,b),ans);
+#else
+    return rb_ary_new3(3,a,b,ans);
+#endif
+}
+
+#undef func_p
+#undef args_t
+#undef LSS
+#undef LSD
+#undef LSY