ruby-lapack 1.7 → 1.7.1

data/ext/stgex2.c

@@ -0,0 +1,184 @@
+#include "rb_lapack.h"
+
+extern VOID stgex2_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* j1, integer* n1, integer* n2, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_stgex2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_q;
+  real *q; 
+  VALUE rblapack_ldq;
+  integer ldq; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_j1;
+  integer j1; 
+  VALUE rblapack_n1;
+  integer n1; 
+  VALUE rblapack_n2;
+  integer n2; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  real *a_out__;
+  VALUE rblapack_b_out__;
+  real *b_out__;
+  VALUE rblapack_q_out__;
+  real *q_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+  real *work;
+
+  integer lda;
+  integer n;
+  integer ldb;
+  integer ldz;
+
+  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  info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n*  of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n*  (A, B) by an orthogonal equivalence transformation.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A      (input/output) REAL arrays, dimensions (LDA,N)\n*          On entry, the matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B      (input/output) REAL arrays, dimensions (LDB,N)\n*          On entry, the matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          Not referenced if WANTQ = .FALSE..\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          Not referenced if WANTZ = .FALSE..\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  J1      (input) INTEGER\n*          The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n*  N1      (input) INTEGER\n*          The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)).\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >=  MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n*  INFO    (output) INTEGER\n*            =0: Successful exit\n*            >0: If INFO = 1, the transformed matrix (A, B) would be\n*                too far from generalized Schur form; the blocks are\n*                not swapped and (A, B) and (Q, Z) are unchanged.\n*                The problem of swapping is too ill-conditioned.\n*            <0: If INFO = -16: LWORK is too small. Appropriate value\n*                for LWORK is returned in WORK(1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  In the current code both weak and strong stability tests are\n*  performed. The user can omit the strong stability test by changing\n*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n*  details.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  =====================================================================\n*  Replaced various illegal calls to SCOPY by calls to SLASET, or by DO\n*  loops. Sven Hammarling, 1/5/02.\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 10 && argc != 11)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+  rblapack_wantq = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_a = argv[2];
+  rblapack_b = argv[3];
+  rblapack_q = argv[4];
+  rblapack_ldq = argv[5];
+  rblapack_z = argv[6];
+  rblapack_j1 = argv[7];
+  rblapack_n1 = argv[8];
+  rblapack_n2 = argv[9];
+  if (argc == 11) {
+    rblapack_lwork = argv[10];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  wantq = (rblapack_wantq == Qtrue);
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, real*);
+  if (!NA_IsNArray(rblapack_q))
+    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+  if (NA_RANK(rblapack_q) != 2)
+    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+  ldz = NA_SHAPE0(rblapack_q);
+  if (NA_SHAPE1(rblapack_q) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, real*);
+  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);
+  if (NA_SHAPE0(rblapack_z) != ldz)
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+  if (NA_SHAPE1(rblapack_z) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  n1 = NUM2INT(rblapack_n1);
+  wantz = (rblapack_wantz == Qtrue);
+  ldq = NUM2INT(rblapack_ldq);
+  n2 = NUM2INT(rblapack_n2);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
+  j1 = NUM2INT(rblapack_j1);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
+  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldb;
+    shape[1] = n;
+    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+  rblapack_b = rblapack_b_out__;
+  b = b_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldz;
+    shape[1] = n;
+    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+  rblapack_q = rblapack_q_out__;
+  q = q_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__;
+  work = ALLOC_N(real, (lwork));
+
+  stgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_stgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stgex2", rblapack_stgex2, -1);
+}

data/ext/stgexc.c

@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID stgexc_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* ifst, integer* ilst, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_stgexc(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_q;
+  real *q; 
+  VALUE rblapack_ldq;
+  integer ldq; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_ifst;
+  integer ifst; 
+  VALUE rblapack_ilst;
+  integer ilst; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_work;
+  real *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  real *a_out__;
+  VALUE rblapack_b_out__;
+  real *b_out__;
+  VALUE rblapack_q_out__;
+  real *q_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+
+  integer lda;
+  integer n;
+  integer ldb;
+  integer ldz;
+
+  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  work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGEXC reorders the generalized real Schur decomposition of a real\n*  matrix pair (A,B) using an orthogonal equivalence transformation\n*\n*                 (A, B) = Q * (A, B) * Z',\n*\n*  so that the diagonal block of (A, B) with row index IFST is moved\n*  to row ILST.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the matrix A in generalized real Schur canonical\n*          form.\n*          On exit, the updated matrix A, again in generalized\n*          real Schur canonical form.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the matrix B in generalized real Schur canonical\n*          form (A,B).\n*          On exit, the updated matrix B, again in generalized\n*          real Schur canonical form (A,B).\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  IFST    (input/output) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of (A, B).\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of swapping between adjacent blocks.\n*          On exit, if IFST pointed on entry to the second row of\n*          a 2-by-2 block, it is changed to point to the first row;\n*          ILST always points to the first row of the block in its\n*          final position (which may differ from its input value by\n*          +1 or -1). 1 <= IFST, ILST <= N.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array, and no error\n*          message related to LWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*           =0:  successful exit.\n*           <0:  if INFO = -i, the i-th argument had an illegal value.\n*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. (A, B) may have been partially reordered,\n*                and ILST points to the first row of the current\n*                position of the block being moved.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [: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_wantq = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_a = argv[2];
+  rblapack_b = argv[3];
+  rblapack_q = argv[4];
+  rblapack_ldq = argv[5];
+  rblapack_z = argv[6];
+  rblapack_ifst = argv[7];
+  rblapack_ilst = 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;
+  }
+
+  wantq = (rblapack_wantq == Qtrue);
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, real*);
+  if (!NA_IsNArray(rblapack_q))
+    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+  if (NA_RANK(rblapack_q) != 2)
+    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+  ldz = NA_SHAPE0(rblapack_q);
+  if (NA_SHAPE1(rblapack_q) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, real*);
+  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);
+  if (NA_SHAPE0(rblapack_z) != ldz)
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+  if (NA_SHAPE1(rblapack_z) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  ilst = NUM2INT(rblapack_ilst);
+  wantz = (rblapack_wantz == Qtrue);
+  ldq = NUM2INT(rblapack_ldq);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  if (rblapack_lwork == Qnil)
+    lwork = n<=1 ? 1 : 4*n+16;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ifst = NUM2INT(rblapack_ifst);
+  {
+    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] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
+  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldb;
+    shape[1] = n;
+    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+  rblapack_b = rblapack_b_out__;
+  b = b_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldz;
+    shape[1] = n;
+    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+  rblapack_q = rblapack_q_out__;
+  q = q_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__;
+
+  stgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);
+
+  rblapack_info = INT2NUM(info);
+  rblapack_ifst = INT2NUM(ifst);
+  rblapack_ilst = INT2NUM(ilst);
+  return rb_ary_new3(8, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ifst, rblapack_ilst);
+}
+
+void
+init_lapack_stgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stgexc", rblapack_stgexc, -1);
+}

data/ext/stgsen.c

@@ -0,0 +1,252 @@
+#include "rb_lapack.h"
+
+extern VOID stgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* q, integer* ldq, real* z, integer* ldz, integer* m, real* pl, real* pr, real* dif, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_stgsen(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_ijob;
+  integer ijob; 
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_select;
+  logical *select; 
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_q;
+  real *q; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_liwork;
+  integer liwork; 
+  VALUE rblapack_alphar;
+  real *alphar; 
+  VALUE rblapack_alphai;
+  real *alphai; 
+  VALUE rblapack_beta;
+  real *beta; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_pl;
+  real pl; 
+  VALUE rblapack_pr;
+  real pr; 
+  VALUE rblapack_dif;
+  real *dif; 
+  VALUE rblapack_work;
+  real *work; 
+  VALUE rblapack_iwork;
+  integer *iwork; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  real *a_out__;
+  VALUE rblapack_b_out__;
+  real *b_out__;
+  VALUE rblapack_q_out__;
+  real *q_out__;
+  VALUE rblapack_z_out__;
+  real *z_out__;
+
+  integer n;
+  integer lda;
+  integer ldb;
+  integer ldq;
+  integer ldz;
+
+  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  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSEN reorders the generalized real Schur decomposition of a real\n*  matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n*  appears in the leading diagonal blocks of the upper quasi-triangular\n*  matrix A and the upper triangular B. The leading columns of Q and\n*  Z form orthonormal bases of the corresponding left and right eigen-\n*  spaces (deflating subspaces). (A, B) must be in generalized real\n*  Schur canonical form (as returned by SGGES), i.e. A is block upper\n*  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n*  triangular.\n*\n*  STGSEN also computes the generalized eigenvalues\n*\n*              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n*  of the reordered matrix pair (A, B).\n*\n*  Optionally, STGSEN computes the estimates of reciprocal condition\n*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n*  the selected cluster and the eigenvalues outside the cluster, resp.,\n*  and norms of \"projections\" onto left and right eigenspaces w.r.t.\n*  the selected cluster in the (1,1)-block.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (PL and PR) or the deflating subspaces\n*          (Difu and Difl):\n*           =0: Only reorder w.r.t. SELECT. No extras.\n*           =1: Reciprocal of norms of \"projections\" onto left and right\n*               eigenspaces w.r.t. the selected cluster (PL and PR).\n*           =2: Upper bounds on Difu and Difl. F-norm-based estimate\n*               (DIF(1:2)).\n*           =3: Estimate of Difu and Difl. 1-norm-based estimate\n*               (DIF(1:2)).\n*               About 5 times as expensive as IJOB = 2.\n*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n*               version to get it all.\n*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster.\n*          To select a real eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE.. To select a complex conjugate pair of eigenvalues\n*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; a complex conjugate pair of eigenvalues must be\n*          either both included in the cluster or both excluded.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) REAL array, dimension(LDA,N)\n*          On entry, the upper quasi-triangular matrix A, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, A is overwritten by the reordered matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension(LDB,N)\n*          On entry, the upper triangular matrix B, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, B is overwritten by the reordered matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i\n*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real generalized Schur form of (A,B) were further reduced\n*          to triangular form using complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n*          On exit, Q has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Q form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1;\n*          and if WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n*          On exit, Z has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Z form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified pair of left and right eigen-\n*          spaces (deflating subspaces). 0 <= M <= N.\n*\n*  PL      (output) REAL\n*  PR      (output) REAL\n*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n*          reciprocal of the norm of \"projections\" onto left and right\n*          eigenspaces with respect to the selected cluster.\n*          0 < PL, PR <= 1.\n*          If M = 0 or M = N, PL = PR  = 1.\n*          If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n*  DIF     (output) REAL array, dimension (2).\n*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n*          estimates of Difu and Difl.\n*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n*          If IJOB = 0 or 1, DIF is not referenced.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >=  4*N+16.\n*          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n*          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array, and no error\n*          message related to LWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK. LIWORK >= 1.\n*          If IJOB = 1, 2 or 4, LIWORK >=  N+6.\n*          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*            =0: Successful exit.\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            =1: Reordering of (A, B) failed because the transformed\n*                matrix pair (A, B) would be too far from generalized\n*                Schur form; the problem is very ill-conditioned.\n*                (A, B) may have been partially reordered.\n*                If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n*  Further Details\n*  ===============\n*\n*  STGSEN first collects the selected eigenvalues by computing\n*  orthogonal U and W that move them to the top left corner of (A, B).\n*  In other words, the selected eigenvalues are the eigenvalues of\n*  (A11, B11) in:\n*\n*                U'*(A, B)*W = (A11 A12) (B11 B12) n1\n*                              ( 0  A22),( 0  B22) n2\n*                                n1  n2    n1  n2\n*\n*  where N = n1+n2 and U' means the transpose of U. The first n1 columns\n*  of U and W span the specified pair of left and right eigenspaces\n*  (deflating subspaces) of (A, B).\n*\n*  If (A, B) has been obtained from the generalized real Schur\n*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n*  reordered generalized real Schur form of (C, D) is given by\n*\n*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n*  and the first n1 columns of Q*U and Z*W span the corresponding\n*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n*  Note that if the selected eigenvalue is sufficiently ill-conditioned,\n*  then its value may differ significantly from its value before\n*  reordering.\n*\n*  The reciprocal condition numbers of the left and right eigenspaces\n*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n*  The Difu and Difl are defined as:\n*\n*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n*  and\n*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n*  where sigma-min(Zu) is the smallest singular value of the\n*  (2*n1*n2)-by-(2*n1*n2) matrix\n*\n*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]\n*            [ kron(In2, B11)  -kron(B22', In1) ].\n*\n*  Here, Inx is the identity matrix of size nx and A22' is the\n*  transpose of A22. kron(X, Y) is the Kronecker product between\n*  the matrices X and Y.\n*\n*  When DIF(2) is small, small changes in (A, B) can cause large changes\n*  in the deflating subspace. An approximate (asymptotic) bound on the\n*  maximum angular error in the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / DIF(2),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal norm of the projectors on the left and right\n*  eigenspaces associated with (A11, B11) may be returned in PL and PR.\n*  They are computed as follows. First we compute L and R so that\n*  P*(A, B)*Q is block diagonal, where\n*\n*       P = ( I -L ) n1           Q = ( I R ) n1\n*           ( 0  I ) n2    and        ( 0 I ) n2\n*             n1 n2                    n1 n2\n*\n*  and (L, R) is the solution to the generalized Sylvester equation\n*\n*       A11*R - L*A22 = -A12\n*       B11*R - L*B22 = -B12\n*\n*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / PL.\n*\n*  There are also global error bounds which valid for perturbations up\n*  to a certain restriction:  A lower bound (x) on the smallest\n*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n*  (i.e. (A + E, B + F), is\n*\n*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n*  An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n*  (L', R') and unperturbed (L, R) left and right deflating subspaces\n*  associated with the selected cluster in the (1,1)-blocks can be\n*  bounded as\n*\n*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n*  See LAPACK User's Guide section 4.11 or the following references\n*  for more information.\n*\n*  Note that if the default method for computing the Frobenius-norm-\n*  based estimate DIF is not wanted (see SLATDF), then the parameter\n*  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF\n*  (IJOB = 2 will be used)). See STGSYL for more details.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 10)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_ijob = argv[0];
+  rblapack_wantq = argv[1];
+  rblapack_wantz = argv[2];
+  rblapack_select = argv[3];
+  rblapack_a = argv[4];
+  rblapack_b = argv[5];
+  rblapack_q = argv[6];
+  rblapack_z = argv[7];
+  if (argc == 10) {
+    rblapack_lwork = argv[8];
+    rblapack_liwork = argv[9];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+  } else {
+    rblapack_lwork = Qnil;
+    rblapack_liwork = Qnil;
+  }
+
+  ijob = NUM2INT(rblapack_ijob);
+  wantz = (rblapack_wantz == Qtrue);
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, real*);
+  if (!NA_IsNArray(rblapack_q))
+    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+  if (NA_RANK(rblapack_q) != 2)
+    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+  ldq = NA_SHAPE0(rblapack_q);
+  if (NA_SHAPE1(rblapack_q) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, real*);
+  wantq = (rblapack_wantq == Qtrue);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  if (!NA_IsNArray(rblapack_select))
+    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+  if (NA_RANK(rblapack_select) != 1)
+    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_select) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_select) != NA_LINT)
+    rblapack_select = na_change_type(rblapack_select, NA_LINT);
+  select = NA_PTR_TYPE(rblapack_select, logical*);
+  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);
+  ldz = NA_SHAPE0(rblapack_z);
+  if (NA_SHAPE1(rblapack_z) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  if (rblapack_liwork == Qnil)
+    liwork = (ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0;
+  else {
+    liwork = NUM2INT(rblapack_liwork);
+  }
+  if (rblapack_lwork == Qnil)
+    lwork = (ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  beta = NA_PTR_TYPE(rblapack_beta, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = 2;
+    rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  dif = NA_PTR_TYPE(rblapack_dif, 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[1];
+    shape[0] = MAX(1,liwork);
+    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
+  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldb;
+    shape[1] = n;
+    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+  rblapack_b = rblapack_b_out__;
+  b = b_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldq;
+    shape[1] = n;
+    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+  rblapack_q = rblapack_q_out__;
+  q = q_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__;
+
+  stgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
+
+  rblapack_m = INT2NUM(m);
+  rblapack_pl = rb_float_new((double)pl);
+  rblapack_pr = rb_float_new((double)pr);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(14, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_stgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stgsen", rblapack_stgsen, -1);
+}