numo-linalg 0.0.1

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

@@ -0,0 +1,149 @@
+/*<%
+ uplo = (/^?ge/=~name) ? nil : "g->uplo,"
+ ipiv = (/^?po/=~name) ? nil : "ipiv,"
+%>*/
+<% %>
+#define UPLO <%=(/^?ge/!~name) ? "1":"0"%>
+#define IPIV <%=(/^?po/!~name) ? "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_name%>_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t * const lp)
+{
+    dtype *a, *b;
+    int   *info;
+    int    n, nrhs;
+    int    lda, ldb;
+    args_t *g;
+#if IPIV
+    int *ipiv;
+    ipiv = (int*)NDL_PTR(lp,2);
+    info = (int*)NDL_PTR(lp,3);
+#else
+    info = (int*)NDL_PTR(lp,2);
+#endif
+    a = (dtype*)NDL_PTR(lp,0);
+    b = (dtype*)NDL_PTR(lp,1);
+    g = (args_t*)(lp->opt_ptr);
+
+    n = NDL_SHAPE(lp,0)[0];
+    lda = NDL_STEP(lp,0) / sizeof(dtype);
+    if (lp->args[1].ndim == 1) {
+        nrhs = 1;
+        ldb = (g->order==LAPACK_COL_MAJOR) ? n : 1;
+    } else {
+        nrhs = NDL_SHAPE(lp,1)[1];
+        ldb = NDL_STEP(lp,1) / sizeof(dtype);
+    }
+    //printf("order=%d n=%d nrhs=%d lda=%d ldb=%d b.ndim=%d\n",
+    //       g->order,n,nrhs,lda,ldb,lp->args[1].ndim);
+    *info = (*func_p)( g->order, <%=uplo%>
+                       n, nrhs, a, lda, <%=ipiv%> b, ldb );
+    CHECK_ERROR(*info);
+}
+
+/*<%
+ tp = class_name
+ iary = "Numo::Int"
+ iscal = "Integer"
+ if uplo
+   a = "a, b, [uplo:'U', order:'R']"
+ else
+   a = "a, b, [order:'R']"
+ end
+ if ipiv
+   n = "a, b, ipiv, info"
+   t = [tp,tp,iary,iscal]
+ else
+   n = "a, b, info"
+   t = [tp,tp,iscal]
+ end
+ return_type = t.join(", ")
+ return_name = n
+ args_v = a
+
+ params = [
+   mat("a",:inplace,"output: lu"),
+   vec("b",:inplace,"output: x"),
+   uplo && opt("uplo"),
+   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;
+    narray_t *na1, *na2;
+    size_t n, nb, nrhs;
+    ndfunc_arg_in_t ain[2] = {{OVERWRITE,2},{OVERWRITE,2}};
+    size_t shape[2];
+    ndfunc_arg_out_t aout[2] = {{cInt,1,shape},{cInt,0}};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT, 2,2, ain,aout};
+    args_t g;
+    VALUE kw_hash = Qnil;
+    ID kw_table[2] = {id_order,id_uplo};
+    VALUE opts[2] = {Qundef,Qundef};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    rb_scan_args(argc, argv, "2:", &a, &b, &kw_hash);
+    rb_get_kwargs(kw_hash, kw_table, 0, 2, opts);
+    g.order = option_order(opts[0]);
+    g.uplo = option_uplo(opts[1]);
+
+    COPY_OR_CAST_TO(a,cT);
+    COPY_OR_CAST_TO(b,cT);
+    GetNArray(a, na1);
+    GetNArray(b, na2);
+    CHECK_DIM_GE(na1, 2);
+    CHECK_DIM_GE(na2, 1);
+    CHECK_SQUARE("matrix a",na1);
+    n = COL_SIZE(na1);
+    if (NA_NDIM(na2) == 1) {
+        ain[1].dim = 1;
+        nb = COL_SIZE(na2);
+        nrhs = 1;
+    } else {
+        nb = ROW_SIZE(na2);
+        nrhs = COL_SIZE(na2);
+    }
+    if (n != nb) {
+        rb_raise(nary_eShapeError, "matrix dimension mismatch: "
+                 "a.col=a.row=%"SZF"u b.row=%"SZF"u", n, nb);
+    }
+    shape[0] = n;
+    shape[1] = nrhs;
+#if !IPIV
+    ndf.aout++;
+    ndf.nout--;
+#endif
+
+    ans = na_ndloop3(&ndf, &g, 2, a, b);
+
+#if IPIV
+    return rb_ary_concat(rb_assoc_new(a,b),ans);
+#else
+    return rb_ary_new3(3,a,b,ans);
+#endif
+}
+
+#undef func_p
+#undef args_t
+#undef UPLO
+#undef IPIV

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

@@ -0,0 +1,189 @@
+//<% is_sdd = (/gesdd/ =~ name) %>
+#define SDD <%=is_sdd ? "1":"0"%>
+#define args_t <%=func_name%>_args_t
+#define func_p <%=func_name%>_p
+
+typedef struct {
+    int order;
+    char jobu, jobvt, jobz;
+    rtype *superb;
+} args_t;
+
+static <%=func_name%>_t func_p = 0;
+
+static void
+<%=c_iter%>(na_loop_t * const lp)
+{
+    dtype *a, *u=0, *vt=0;
+    rtype *s;
+    int   *info;
+    int    m, n, lda, ldu, ldvt, tmp;
+    args_t *g;
+
+    a = (dtype*)NDL_PTR(lp,0);
+    s = (rtype*)NDL_PTR(lp,1);
+    u = (dtype*)NDL_PTR(lp,2);
+    vt = (dtype*)NDL_PTR(lp,3);
+    info = (int*)NDL_PTR(lp,4);
+    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);
+    ldu = NDL_STEP(lp,2) / sizeof(dtype);
+    if (ldu == 0) { ldu = m; } // jobu == 'O' or 'N'
+    ldvt = NDL_STEP(lp,3) / sizeof(dtype);
+    if (ldvt == 0) { ldvt = n; } // jobvt == 'O' or 'N'
+
+    //printf("order=%d jobu=%c jobvt=%c jobz=%c m=%d n=%d lda=%d ldu=%d ldvt=%d\n",g->order,g->jobu, g->jobvt,g->jobz, m,n,lda,ldu,ldvt);
+
+    /*<%
+    job = (is_sdd) ? "g->jobz" : "g->jobu, g->jobvt"
+    spb = (is_sdd) ? "" : ", g->superb"
+    %>*/
+    *info = (*func_p)( g->order, <%=job%>, m, n, a, lda, s,
+                       u, ldu, vt, ldvt <%=spb%> );
+    CHECK_ERROR(*info);
+}
+
+/*<%
+ tp = class_name
+ iscal = "Integer"
+ if is_sdd
+   a = "a, [jobz:'A', order:'R']"
+ else
+   a = "a, [jobu:'A', jobvt:'A', order:'R']"
+ end
+ return_type = [tp,tp,tp,iscal].join(", ")
+ return_name = "sigma, u, vt, info"
+ args_v = a
+ params = [
+   mat("a","inplace allowed if job\\*=='O'"),
+   *(is_sdd ? [jobs("jobz")] : [jobs("jobu"),jobs("jobvt")]),
+   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))
+{
+#if !SDD
+    VALUE tmpbuf;
+#endif
+    VALUE a, ans;
+    int   m, n, min_mn, tmp;
+    narray_t *na1;
+    size_t shape_s[1], shape_u[2], shape_vt[2];
+    ndfunc_arg_in_t ain[1] = {{OVERWRITE,2}};
+    ndfunc_arg_out_t aout[4] = {{cRT,1,shape_s},{cT,2,shape_u},
+                                {cT,2,shape_vt},{cInt,0}};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT, 1, 4, ain, aout};
+
+    args_t g;
+    VALUE opts[4] = {Qundef,Qundef,Qundef,Qundef};
+    VALUE kw_hash = Qnil;
+    ID kw_table[4] = {id_order,id_jobu,id_jobvt,id_jobz};
+
+    CHECK_FUNC(func_p,"<%=func_name%>");
+
+    rb_scan_args(argc, argv, "1:", &a, &kw_hash);
+    rb_get_kwargs(kw_hash, kw_table, 0, 4, opts);
+    g.order = option_order(opts[0]);
+#if SDD
+    g.jobz = option_job(opts[3],'A','N');
+    g.jobu = g.jobvt = g.jobz;
+#else
+    g.jobu  = option_job(opts[1],'A','N');
+    g.jobvt = option_job(opts[2],'A','N');
+    if (g.jobu=='O' && g.jobvt=='O') {
+        rb_raise(rb_eArgError,"JOBVT and JOBU cannot both be 'O'");
+    }
+#endif
+
+    if (g.jobu=='O' || g.jobvt=='O') {
+        if (CLASS_OF(a) != cT) {
+            rb_raise(rb_eTypeError,"type of matrix a is invalid for overwrite");
+        }
+    } else {
+        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 SDD
+    if (g.jobz=='O') {
+        if (m >= n) { g.jobvt='A';} else { g.jobu='A';}
+    }
+#endif
+
+    // output S
+    shape_s[0] = min_mn = min_(m,n);
+
+    // output U
+    switch(g.jobu){
+    case 'A':
+        shape_u[0] = m;
+        shape_u[1] = m;
+        break;
+    case 'S':
+        shape_u[0] = m;
+        shape_u[1] = min_mn;
+        SWAP_IFCOL(g.order,shape_u[0],shape_u[1]);
+        break;
+    case 'O':
+    case 'N':
+        aout[1].dim = 0; // dummy
+        break;
+    default:
+        rb_raise(rb_eArgError,"invalid option: jobu='%c'",g.jobu);
+    }
+    // output VT
+    switch(g.jobvt){
+    case 'A':
+        shape_vt[0] = n;
+        shape_vt[1] = n;
+        break;
+    case 'S':
+        shape_vt[0] = min_mn;
+        shape_vt[1] = n;
+        SWAP_IFCOL(g.order, shape_vt[0], shape_vt[1]);
+        break;
+    case 'O':
+    case 'N':
+        aout[2].dim = 0; // dummy
+        break;
+    default:
+        rb_raise(rb_eArgError,"invalid option: jobvt='%c'",g.jobvt);
+    }
+#if !SDD
+    g.superb = (rtype*)rb_alloc_tmp_buffer(&tmpbuf, min_mn*sizeof(rtype));
+#endif
+
+    ans = na_ndloop3(&ndf, &g, 1, a);
+
+#if !SDD
+    rb_free_tmp_buffer(&tmpbuf);
+#endif
+
+    if (g.jobu=='O')      { RARRAY_ASET(ans,1,a); } else
+    if (aout[1].dim == 0) { RARRAY_ASET(ans,1,Qnil); }
+    if (g.jobvt=='O')     { RARRAY_ASET(ans,2,a); } else
+    if (aout[2].dim == 0) { RARRAY_ASET(ans,2,Qnil); }
+    return ans;
+}
+
+#undef args_t
+#undef func_p
+#undef SDD

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

@@ -0,0 +1,138 @@
+#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, *b, *beta, *vl, *vr;
+#if IS_COMPLEX
+    dtype *alpha;
+#else
+    dtype *alphar, *alphai;
+#endif
+    int   *info;
+    int    n, lda, ldb, ldvl, ldvr;
+    args_t *g;
+
+    a = (dtype*)NDL_PTR(lp,0);
+    b = (dtype*)NDL_PTR(lp,1);
+#if IS_COMPLEX
+    alpha = (dtype*)NDL_PTR(lp,2);
+#else
+    alphar = (dtype*)NDL_PTR(lp,2);
+    alphai = (dtype*)NDL_PTR(lp,3);
+#endif
+    beta = (dtype*)NDL_PTR(lp,4-CZ);
+    vl = (dtype*)NDL_PTR(lp,5-CZ);
+    vr = (dtype*)NDL_PTR(lp,6-CZ);
+    info = (int*)NDL_PTR(lp,7-CZ);
+    g = (args_t*)(lp->opt_ptr);
+
+    n = NDL_SHAPE(lp,0)[1];
+    lda = NDL_STEP(lp,0) / sizeof(dtype);
+    ldb = NDL_STEP(lp,1) / sizeof(dtype);
+    ldvl = NDL_STEP(lp,5-CZ) / sizeof(dtype);
+    if (ldvl == 0) { ldvl = n; } // jobvl == 'N'
+    ldvr = NDL_STEP(lp,6-CZ) / sizeof(dtype);
+    if (ldvr == 0) { ldvr = n; } // jobvr == 'N'
+
+    //printf("order=%d jobvl=%c jobvr=%c n=%d lda=%d ldb=%d ldvl=%d ldvr=%d\n",g->order,g->jobvl, g->jobvr, n, lda,ldb,ldvl,ldvr);
+
+    /*<%
+    func_args = [
+      "g->order, g->jobvl, g->jobvr, n, a, lda, b, ldb",
+      is_complex ? "alpha" : "alphar, alphai",
+      "beta, vl, ldvl, vr, ldvr"
+    ].join(",")
+    %>*/
+    *info = (*func_p)(<%=func_args%>);
+    CHECK_ERROR(*info);
+}
+
+/*
+<%
+ tp = class_name
+ return_type = ([tp]*(is_complex ? 4 : 5)+["Integer"]).join(", ")
+ return_name = (is_complex ? "alpha,":"alphar, alphai,")+" beta, vl, vr, info"
+ params = [
+   mat("a",:inplace),
+   mat("b",:inplace),
+   jobe("jobvl"),
+   jobe("jobvr"),
+   opt("order"),
+ ].select{|x| x}.join("\n  ")
+%>
+  @overload <%=name%>(a, b, [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, b, ans;
+    int   n, nb;
+    narray_t *na1, *na2;
+    /*<%
+    aout = [
+      "{cT,1,shape},{cT,1,shape}",
+      !is_complex ? "{cT,1,shape}":nil,
+      "{cT,2,shape},{cT,2,shape},{cInt,0}"
+    ].compact
+    %>*/
+    size_t shape[2];
+    ndfunc_arg_in_t ain[2] = {{OVERWRITE,2},{OVERWRITE,2}};
+    ndfunc_arg_out_t aout[6-CZ] = {<%=aout.join(",")%>};
+    ndfunc_t ndf = {&<%=c_iter%>, NO_LOOP|NDF_EXTRACT, 2, 6-CZ, ain, aout};
+
+    args_t g;
+    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, "2:", &a, &b, &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);
+
+    COPY_OR_CAST_TO(b,cT);
+    GetNArray(b, na2);
+    CHECK_DIM_GE(na2, 2);
+
+    CHECK_SQUARE("matrix a",na1);
+    n  = COL_SIZE(na1);
+    CHECK_SQUARE("matrix b",na2);
+    nb = COL_SIZE(na2);
+    if (n != nb) {
+        rb_raise(nary_eShapeError,"matrix a and b must have same size");
+    }
+    shape[0] = shape[1] = n;
+    if (g.jobvl=='N') { aout[3-CZ].dim = 0; }
+    if (g.jobvr=='N') { aout[4-CZ].dim = 0; }
+
+    ans = na_ndloop3(&ndf, &g, 2, a, b);
+
+    if (aout[4-CZ].dim == 0) { RARRAY_ASET(ans,4-CZ,Qnil); }
+    if (aout[3-CZ].dim == 0) { RARRAY_ASET(ans,3-CZ,Qnil); }
+    return ans;
+}
+
+#undef args_t
+#undef func_p