ruby-lapack 1.7 → 1.7.1

data/ext/slaqr1.c

@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr1_(integer* n, real* h, integer* ldh, real* sr1, real* si1, real* sr2, real* si2, real* v);
+
+
+static VALUE
+rblapack_slaqr1(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_h;
+  real *h; 
+  VALUE rblapack_sr1;
+  real sr1; 
+  VALUE rblapack_si1;
+  real si1; 
+  VALUE rblapack_sr2;
+  real sr2; 
+  VALUE rblapack_si2;
+  real si2; 
+  VALUE rblapack_v;
+  real *v; 
+
+  integer ldh;
+  integer n;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n*       scaling to avoid overflows and most underflows. It\n*       is assumed that either\n*\n*               1) sr1 = sr2 and si1 = -si2\n*           or\n*               2) si1 = si2 = 0.\n*\n*       This is useful for starting double implicit shift bulges\n*       in the QR algorithm.\n*\n*\n\n*       N      (input) integer\n*              Order of the matrix H. N must be either 2 or 3.\n*\n*       H      (input) REAL array of dimension (LDH,N)\n*              The 2-by-2 or 3-by-3 matrix H in (*).\n*\n*       LDH    (input) integer\n*              The leading dimension of H as declared in\n*              the calling procedure.  LDH.GE.N\n*\n*       SR1    (input) REAL\n*       SI1    The shifts in (*).\n*       SR2\n*       SI2\n*\n*       V      (output) REAL array of dimension N\n*              A scalar multiple of the first column of the\n*              matrix K in (*).\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 5 && argc != 5)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+  rblapack_h = argv[0];
+  rblapack_sr1 = argv[1];
+  rblapack_si1 = argv[2];
+  rblapack_sr2 = argv[3];
+  rblapack_si2 = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (1th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  n = NA_SHAPE1(rblapack_h);
+  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+  h = NA_PTR_TYPE(rblapack_h, real*);
+  si1 = (real)NUM2DBL(rblapack_si1);
+  si2 = (real)NUM2DBL(rblapack_si2);
+  sr1 = (real)NUM2DBL(rblapack_sr1);
+  sr2 = (real)NUM2DBL(rblapack_sr2);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_v = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  v = NA_PTR_TYPE(rblapack_v, real*);
+
+  slaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);
+
+  return rblapack_v;
+}
+
+void
+init_lapack_slaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaqr1", rblapack_slaqr1, -1);
+}

data/ext/slaqr2.c

@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);
+
+
+static VALUE
+rblapack_slaqr2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantt;
+  logical wantt; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_ktop;
+  integer ktop; 
+  VALUE rblapack_kbot;
+  integer kbot; 
+  VALUE rblapack_nw;
+  integer nw; 
+  VALUE rblapack_h;
+  real *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_nh;
+  integer nh; 
+  VALUE rblapack_nv;
+  integer nv; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_ns;
+  integer ns; 
+  VALUE rblapack_nd;
+  integer nd; 
+  VALUE rblapack_sr;
+  real *sr; 
+  VALUE rblapack_si;
+  real *si; 
+  VALUE rblapack_h_out__;
+  real *h_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+  real *v;
+  real *t;
+  real *wv;
+  real *work;
+
+  integer ldh;
+  integer n;
+  integer ldz;
+  integer ldv;
+  integer ldt;
+  integer ldwv;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to SLAQR3 except that it avoids\n*     recursion by calling SLAHQR instead of SLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) REAL array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) REAL array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) REAL array, dimension KBOT\n*     SI      (output) REAL array, dimension KBOT\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) REAL array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) REAL array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) REAL array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) REAL array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; SLAQR2\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 11 && argc != 12)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+  rblapack_wantt = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_ktop = argv[2];
+  rblapack_kbot = argv[3];
+  rblapack_nw = argv[4];
+  rblapack_h = argv[5];
+  rblapack_iloz = argv[6];
+  rblapack_ihiz = argv[7];
+  rblapack_z = argv[8];
+  rblapack_nh = argv[9];
+  rblapack_nv = argv[10];
+  if (argc == 12) {
+    rblapack_lwork = argv[11];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  wantt = (rblapack_wantt == Qtrue);
+  ktop = NUM2INT(rblapack_ktop);
+  nw = NUM2INT(rblapack_nw);
+  iloz = NUM2INT(rblapack_iloz);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+  ldz = NA_SHAPE0(rblapack_z);
+  n = NA_SHAPE1(rblapack_z);
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  nv = NUM2INT(rblapack_nv);
+  ldwv = nw;
+  ldv = nw;
+  wantz = (rblapack_wantz == Qtrue);
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  if (NA_SHAPE1(rblapack_h) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+  h = NA_PTR_TYPE(rblapack_h, real*);
+  nh = NUM2INT(rblapack_nh);
+  ldt = nw;
+  kbot = NUM2INT(rblapack_kbot);
+  if (rblapack_lwork == Qnil)
+    lwork = 2*nw;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ihiz = NUM2INT(rblapack_ihiz);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,kbot);
+    rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  sr = NA_PTR_TYPE(rblapack_sr, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,kbot);
+    rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  si = NA_PTR_TYPE(rblapack_si, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+  rblapack_h = rblapack_h_out__;
+  h = h_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldz;
+    shape[1] = n;
+    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+  v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
+  t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
+  wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
+  work = ALLOC_N(real, (MAX(1,lwork)));
+
+  slaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+  free(v);
+  free(t);
+  free(wv);
+  free(work);
+  rblapack_ns = INT2NUM(ns);
+  rblapack_nd = INT2NUM(nd);
+  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaqr2", rblapack_slaqr2, -1);
+}

data/ext/slaqr3.c

@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);
+
+
+static VALUE
+rblapack_slaqr3(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantt;
+  logical wantt; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_ktop;
+  integer ktop; 
+  VALUE rblapack_kbot;
+  integer kbot; 
+  VALUE rblapack_nw;
+  integer nw; 
+  VALUE rblapack_h;
+  real *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_nh;
+  integer nh; 
+  VALUE rblapack_nv;
+  integer nv; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_ns;
+  integer ns; 
+  VALUE rblapack_nd;
+  integer nd; 
+  VALUE rblapack_sr;
+  real *sr; 
+  VALUE rblapack_si;
+  real *si; 
+  VALUE rblapack_h_out__;
+  real *h_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+  real *v;
+  real *t;
+  real *wv;
+  real *work;
+
+  integer ldh;
+  integer n;
+  integer ldz;
+  integer ldv;
+  integer ldt;
+  integer ldwv;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) REAL array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) REAL array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) REAL array, dimension KBOT\n*     SI      (output) REAL array, dimension KBOT\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) REAL array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) REAL array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) REAL array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) REAL array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; SLAQR3\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 11 && argc != 12)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+  rblapack_wantt = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_ktop = argv[2];
+  rblapack_kbot = argv[3];
+  rblapack_nw = argv[4];
+  rblapack_h = argv[5];
+  rblapack_iloz = argv[6];
+  rblapack_ihiz = argv[7];
+  rblapack_z = argv[8];
+  rblapack_nh = argv[9];
+  rblapack_nv = argv[10];
+  if (argc == 12) {
+    rblapack_lwork = argv[11];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  wantt = (rblapack_wantt == Qtrue);
+  ktop = NUM2INT(rblapack_ktop);
+  nw = NUM2INT(rblapack_nw);
+  iloz = NUM2INT(rblapack_iloz);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+  ldz = NA_SHAPE0(rblapack_z);
+  n = NA_SHAPE1(rblapack_z);
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  nv = NUM2INT(rblapack_nv);
+  ldwv = nw;
+  ldv = nw;
+  wantz = (rblapack_wantz == Qtrue);
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  if (NA_SHAPE1(rblapack_h) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+  h = NA_PTR_TYPE(rblapack_h, real*);
+  nh = NUM2INT(rblapack_nh);
+  ldt = nw;
+  kbot = NUM2INT(rblapack_kbot);
+  if (rblapack_lwork == Qnil)
+    lwork = 2*nw;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ihiz = NUM2INT(rblapack_ihiz);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,kbot);
+    rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  sr = NA_PTR_TYPE(rblapack_sr, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,kbot);
+    rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  si = NA_PTR_TYPE(rblapack_si, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+  rblapack_h = rblapack_h_out__;
+  h = h_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldz;
+    shape[1] = n;
+    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+  v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
+  t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
+  wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
+  work = ALLOC_N(real, (MAX(1,lwork)));
+
+  slaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+  free(v);
+  free(t);
+  free(wv);
+  free(work);
+  rblapack_ns = INT2NUM(ns);
+  rblapack_nd = INT2NUM(nd);
+  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaqr3", rblapack_slaqr3, -1);
+}

data/ext/slaqr4.c

@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_slaqr4(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantt;
+  logical wantt; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_ilo;
+  integer ilo; 
+  VALUE rblapack_h;
+  real *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_wr;
+  real *wr; 
+  VALUE rblapack_wi;
+  real *wi; 
+  VALUE rblapack_work;
+  real *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_h_out__;
+  real *h_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+
+  integer ldh;
+  integer n;
+  integer ldz;
+  integer ihi;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SLAQR4 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to SGEBAL, and then passed to SGEHRD when the\n*           matrix output by SGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) REAL array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n*           the upper quasi-triangular matrix T from the Schur\n*           decomposition (the Schur form); 2-by-2 diagonal blocks\n*           (corresponding to complex conjugate pairs of eigenvalues)\n*           are returned in standard form, with H(i,i) = H(i+1,i+1)\n*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) REAL array, dimension (IHI)\n*     WI    (output) REAL array, dimension (IHI)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n*           and WI(ILO:IHI). If two eigenvalues are computed as a\n*           complex conjugate pair, they are stored in consecutive\n*           elements of WR and WI, say the i-th and (i+1)th, with\n*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n*           the eigenvalues are stored in the same order as on the\n*           diagonal of the Schur form returned in H, with\n*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     ILOZ     (input) INTEGER\n*     IHIZ     (input) INTEGER\n*           Specify the rows of Z to which transformations must be\n*           applied if WANTZ is .TRUE..\n*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n*     Z     (input/output) REAL array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) REAL array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then SLAQR4 does a workspace query.\n*           In this case, SLAQR4 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, SLAQR4 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 7 && argc != 8)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+  rblapack_wantt = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_ilo = argv[2];
+  rblapack_h = argv[3];
+  rblapack_iloz = argv[4];
+  rblapack_ihiz = argv[5];
+  rblapack_z = argv[6];
+  if (argc == 8) {
+    rblapack_lwork = argv[7];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  wantt = (rblapack_wantt == Qtrue);
+  ilo = NUM2INT(rblapack_ilo);
+  iloz = NUM2INT(rblapack_iloz);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+  ldz = NA_SHAPE0(rblapack_z);
+  ihi = NA_SHAPE1(rblapack_z);
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  wantz = (rblapack_wantz == Qtrue);
+  ihiz = NUM2INT(rblapack_ihiz);
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  n = NA_SHAPE1(rblapack_h);
+  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+  h = NA_PTR_TYPE(rblapack_h, real*);
+  if (rblapack_lwork == Qnil)
+    lwork = n;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  {
+    na_shape_t shape[1];
+    shape[0] = ihi;
+    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  wr = NA_PTR_TYPE(rblapack_wr, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = ihi;
+    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  wi = NA_PTR_TYPE(rblapack_wi, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+  rblapack_h = rblapack_h_out__;
+  h = h_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldz;
+    shape[1] = ihi;
+    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+
+  slaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaqr4", rblapack_slaqr4, -1);
+}