ruby-lapack 1.7 → 1.7.1

data/ext/zlaqr0.c

@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zlaqr0(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantt;
+  logical wantt; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_ilo;
+  integer ilo; 
+  VALUE rblapack_ihi;
+  integer ihi; 
+  VALUE rblapack_h;
+  doublecomplex *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  doublecomplex *z; 
+  VALUE rblapack_ldz;
+  integer ldz; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_w;
+  doublecomplex *w; 
+  VALUE rblapack_work;
+  doublecomplex *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_h_out__;
+  doublecomplex *h_out__;
+  VALUE rblapack_z_out__;
+  doublecomplex *z_out__;
+
+  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  w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZLAQR0 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**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\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 unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\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 ZGEBAL, and then passed to ZGEHRD when the\n*           matrix output by ZGEBAL 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) COMPLEX*16 array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H\n*           contains the upper triangular matrix T from the Schur\n*           decomposition (the Schur form). If INFO = 0 and WANT 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*     W        (output) COMPLEX*16 array, dimension (N)\n*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX*16 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) COMPLEX*16 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 ZLAQR0 does a workspace query.\n*           In this case, ZLAQR0 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, ZLAQR0 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 a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                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 unitary 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  w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 9 && argc != 10)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+  rblapack_wantt = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_ilo = argv[2];
+  rblapack_ihi = argv[3];
+  rblapack_h = argv[4];
+  rblapack_iloz = argv[5];
+  rblapack_ihiz = argv[6];
+  rblapack_z = argv[7];
+  rblapack_ldz = argv[8];
+  if (argc == 10) {
+    rblapack_lwork = argv[9];
+  } 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);
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  n = NA_SHAPE1(rblapack_h);
+  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+  ihiz = NUM2INT(rblapack_ihiz);
+  ldz = NUM2INT(rblapack_ldz);
+  wantz = (rblapack_wantz == Qtrue);
+  iloz = NUM2INT(rblapack_iloz);
+  if (rblapack_lwork == Qnil)
+    lwork = n;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ihi = NUM2INT(rblapack_ihi);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+  if (NA_SHAPE1(rblapack_z) != (wantz ? ihi : 0))
+    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihi : 0);
+  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+  rblapack_h = rblapack_h_out__;
+  h = h_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = wantz ? ldz : 0;
+    shape[1] = wantz ? ihi : 0;
+    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
+  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+
+  zlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlaqr0", rblapack_zlaqr0, -1);
+}

data/ext/zlaqr1.c

@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr1_(integer* n, doublecomplex* h, integer* ldh, doublecomplex* s1, doublecomplex* s2, doublecomplex* v);
+
+
+static VALUE
+rblapack_zlaqr1(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_h;
+  doublecomplex *h; 
+  VALUE rblapack_s1;
+  doublecomplex s1; 
+  VALUE rblapack_s2;
+  doublecomplex s2; 
+  VALUE rblapack_v;
+  doublecomplex *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.zlaqr1( h, s1, s2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - s1*I)*(H - s2*I)\n*\n*       scaling to avoid overflows and most underflows.\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) COMPLEX*16 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*       S1     (input) COMPLEX*16\n*       S2     S1 and S2 are the shifts defining K in (*) above.\n*\n*       V      (output) COMPLEX*16 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.zlaqr1( h, s1, s2, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 3 && argc != 3)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+  rblapack_h = argv[0];
+  rblapack_s1 = argv[1];
+  rblapack_s2 = argv[2];
+  if (argc == 3) {
+  } 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_DCOMPLEX)
+    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+  s2.r = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("real"), 0));
+  s2.i = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("imag"), 0));
+  s1.r = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("real"), 0));
+  s1.i = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("imag"), 0));
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_v = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+
+  zlaqr1_(&n, h, &ldh, &s1, &s2, v);
+
+  return rblapack_v;
+}
+
+void
+init_lapack_zlaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlaqr1", rblapack_zlaqr1, -1);
+}

data/ext/zlaqr2.c

@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);
+
+
+static VALUE
+rblapack_zlaqr2(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;
+  doublecomplex *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  doublecomplex *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_sh;
+  doublecomplex *sh; 
+  VALUE rblapack_h_out__;
+  doublecomplex *h_out__;
+  VALUE rblapack_z_out__;
+  doublecomplex *z_out__;
+  doublecomplex *v;
+  doublecomplex *t;
+  doublecomplex *wv;
+  doublecomplex *work;
+
+  integer ldh;
+  integer n;
+  integer ldz;
+  integer ldv;
+  integer ldwv;
+  integer ldt;
+
+  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, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to ZLAQR3 except that it avoids\n*     recursion by calling ZLAHQR instead of ZLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an unitary 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 unitary 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 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 unitary matrix Z is updated so\n*          so that the unitary 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 unitary 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) COMPLEX*16 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 a unitary\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) COMPLEX*16 array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\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*     SH      (output) COMPLEX*16 array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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; ZLAQR2\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, sh, h, z = NumRu::Lapack.zlaqr2( 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_DCOMPLEX)
+    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+  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_DCOMPLEX)
+    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+  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_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+  MEMCPY(h_out__, h, doublecomplex, 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_DCOMPLEX, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
+  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+  v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+
+  zlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, 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(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlaqr2", rblapack_zlaqr2, -1);
+}

data/ext/zlaqr3.c

@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);
+
+
+static VALUE
+rblapack_zlaqr3(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;
+  doublecomplex *h; 
+  VALUE rblapack_iloz;
+  integer iloz; 
+  VALUE rblapack_ihiz;
+  integer ihiz; 
+  VALUE rblapack_z;
+  doublecomplex *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_sh;
+  doublecomplex *sh; 
+  VALUE rblapack_h_out__;
+  doublecomplex *h_out__;
+  VALUE rblapack_z_out__;
+  doublecomplex *z_out__;
+  doublecomplex *v;
+  doublecomplex *t;
+  doublecomplex *wv;
+  doublecomplex *work;
+
+  integer ldh;
+  integer n;
+  integer ldz;
+  integer ldv;
+  integer ldwv;
+  integer ldt;
+
+  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, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, 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 unitary 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 unitary 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 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 unitary matrix Z is updated so\n*          so that the unitary 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 unitary 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) COMPLEX*16 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 a unitary\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) COMPLEX*16 array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\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*     SH      (output) COMPLEX*16 array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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; ZLAQR3\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, sh, h, z = NumRu::Lapack.zlaqr3( 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_DCOMPLEX)
+    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+  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_DCOMPLEX)
+    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+  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_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldh;
+    shape[1] = n;
+    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+  MEMCPY(h_out__, h, doublecomplex, 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_DCOMPLEX, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
+  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+  v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+
+  zlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, 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(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlaqr3", rblapack_zlaqr3, -1);
+}