ruby-lapack 1.7 → 1.7.1

data/ext/dtfttr.c

@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID dtfttr_(char* transr, char* uplo, integer* n, doublereal* arf, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dtfttr(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_transr;
+  char transr; 
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_arf;
+  doublereal *arf; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_info;
+  integer info; 
+  integer ldarf;
+
+  integer lda;
+  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  a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTFTTR copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'T':  ARF is in Transpose format.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices ARF and A. N >= 0.\n*\n*  ARF     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2).\n*          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n*          matrix A in RFP format. See the \"Notes\" below for more\n*          details.\n*\n*  A       (output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            LOWER, NISODD, NORMALTRANSR\n      INTEGER            N1, N2, K, NT, NX2, NP1X2\n      INTEGER            I, J, L, IJ\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MOD\n*     ..\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [: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_transr = argv[0];
+  rblapack_uplo = argv[1];
+  rblapack_arf = argv[2];
+  if (argc == 3) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  transr = StringValueCStr(rblapack_transr)[0];
+  if (!NA_IsNArray(rblapack_arf))
+    rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
+  if (NA_RANK(rblapack_arf) != 1)
+    rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
+  ldarf = NA_SHAPE0(rblapack_arf);
+  if (NA_TYPE(rblapack_arf) != NA_DFLOAT)
+    rblapack_arf = na_change_type(rblapack_arf, NA_DFLOAT);
+  arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
+  lda = MAX(1,n);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+  dtfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_dtfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dtfttr", rblapack_dtfttr, -1);
+}

data/ext/dtgevc.c

@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dtgevc_(char* side, char* howmny, logical* select, integer* n, doublereal* s, integer* lds, doublereal* p, integer* ldp, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dtgevc(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_side;
+  char side; 
+  VALUE rblapack_howmny;
+  char howmny; 
+  VALUE rblapack_select;
+  logical *select; 
+  VALUE rblapack_s;
+  doublereal *s; 
+  VALUE rblapack_p;
+  doublereal *p; 
+  VALUE rblapack_vl;
+  doublereal *vl; 
+  VALUE rblapack_vr;
+  doublereal *vr; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_vl_out__;
+  doublereal *vl_out__;
+  VALUE rblapack_vr_out__;
+  doublereal *vr_out__;
+  doublereal *work;
+
+  integer n;
+  integer lds;
+  integer ldp;
+  integer ldvl;
+  integer mm;
+  integer ldvr;
+
+  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  m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEVC computes some or all of the right and/or left eigenvectors of\n*  a pair of real matrices (S,P), where S is a quasi-triangular matrix\n*  and P is upper triangular.  Matrix pairs of this type are produced by\n*  the generalized Schur factorization of a matrix pair (A,B):\n*\n*     A = Q*S*Z**T,  B = Q*P*Z**T\n*\n*  as computed by DGGHRD + DHGEQZ.\n*\n*  The right eigenvector x and the left eigenvector y of (S,P)\n*  corresponding to an eigenvalue w are defined by:\n*  \n*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,\n*  \n*  where y**H denotes the conjugate tranpose of y.\n*  The eigenvalues are not input to this routine, but are computed\n*  directly from the diagonal blocks of S and P.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n*  where Z and Q are input matrices.\n*  If Q and Z are the orthogonal factors from the generalized Schur\n*  factorization of a matrix pair (A,B), then Z*X and Q*Y\n*  are the matrices of right and left eigenvectors of (A,B).\n* \n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute all right and/or left eigenvectors;\n*          = 'B': compute all right and/or left eigenvectors,\n*                 backtransformed by the matrices in VR and/or VL;\n*          = 'S': compute selected right and/or left eigenvectors,\n*                 specified by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY='S', SELECT specifies the eigenvectors to be\n*          computed.  If w(j) is a real eigenvalue, the corresponding\n*          real eigenvector is computed if SELECT(j) is .TRUE..\n*          If w(j) and w(j+1) are the real and imaginary parts of a\n*          complex eigenvalue, the corresponding complex eigenvector\n*          is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n*          and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n*          set to .FALSE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices S and P.  N >= 0.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (LDS,N)\n*          The upper quasi-triangular matrix S from a generalized Schur\n*          factorization, as computed by DHGEQZ.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of array S.  LDS >= max(1,N).\n*\n*  P       (input) DOUBLE PRECISION array, dimension (LDP,N)\n*          The upper triangular matrix P from a generalized Schur\n*          factorization, as computed by DHGEQZ.\n*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n*          of S must be in positive diagonal form.\n*\n*  LDP     (input) INTEGER\n*          The leading dimension of array P.  LDP >= max(1,N).\n*\n*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of left Schur vectors returned by DHGEQZ).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VL, in the same order as their eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part, and the second the imaginary part.\n*\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Z (usually the orthogonal matrix Z\n*          of right Schur vectors returned by DHGEQZ).\n*\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n*          if HOWMNY = 'B' or 'b', the matrix Z*X;\n*          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n*                      specified by SELECT, stored consecutively in the\n*                      columns of VR, in the same order as their\n*                      eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part and the second the imaginary part.\n*          \n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected real eigenvector occupies one\n*          column and each selected complex eigenvector occupies two\n*          columns.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex\n*                eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Allocation of workspace:\n*  ---------- -- ---------\n*\n*     WORK( j ) = 1-norm of j-th column of A, above the diagonal\n*     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n*     WORK( 2*N+1:3*N ) = real part of eigenvector\n*     WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n*     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n*     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n*  Rowwise vs. columnwise solution methods:\n*  ------- --  ---------- -------- -------\n*\n*  Finding a generalized eigenvector consists basically of solving the\n*  singular triangular system\n*\n*   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)\n*\n*  Consider finding the i-th right eigenvector (assume all eigenvalues\n*  are real). The equation to be solved is:\n*       n                   i\n*  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1\n*      k=j                 k=j\n*\n*  where  C = (A - w B)  (The components v(i+1:n) are 0.)\n*\n*  The \"rowwise\" method is:\n*\n*  (1)  v(i) := 1\n*  for j = i-1,. . .,1:\n*                          i\n*      (2) compute  s = - sum C(j,k) v(k)   and\n*                        k=j+1\n*\n*      (3) v(j) := s / C(j,j)\n*\n*  Step 2 is sometimes called the \"dot product\" step, since it is an\n*  inner product between the j-th row and the portion of the eigenvector\n*  that has been computed so far.\n*\n*  The \"columnwise\" method consists basically in doing the sums\n*  for all the rows in parallel.  As each v(j) is computed, the\n*  contribution of v(j) times the j-th column of C is added to the\n*  partial sums.  Since FORTRAN arrays are stored columnwise, this has\n*  the advantage that at each step, the elements of C that are accessed\n*  are adjacent to one another, whereas with the rowwise method, the\n*  elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n*  When finding left eigenvectors, the matrix in question is the\n*  transpose of the one in storage, so the rowwise method then\n*  actually accesses columns of A and B at each step, and so is the\n*  preferred method.\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 7 && argc != 7)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+  rblapack_side = argv[0];
+  rblapack_howmny = argv[1];
+  rblapack_select = argv[2];
+  rblapack_s = argv[3];
+  rblapack_p = argv[4];
+  rblapack_vl = argv[5];
+  rblapack_vr = argv[6];
+  if (argc == 7) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  side = StringValueCStr(rblapack_side)[0];
+  if (!NA_IsNArray(rblapack_select))
+    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+  if (NA_RANK(rblapack_select) != 1)
+    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_select);
+  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_p))
+    rb_raise(rb_eArgError, "p (5th argument) must be NArray");
+  if (NA_RANK(rblapack_p) != 2)
+    rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
+  ldp = NA_SHAPE0(rblapack_p);
+  if (NA_SHAPE1(rblapack_p) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
+  if (NA_TYPE(rblapack_p) != NA_DFLOAT)
+    rblapack_p = na_change_type(rblapack_p, NA_DFLOAT);
+  p = NA_PTR_TYPE(rblapack_p, doublereal*);
+  if (!NA_IsNArray(rblapack_vr))
+    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+  if (NA_RANK(rblapack_vr) != 2)
+    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+  ldvr = NA_SHAPE0(rblapack_vr);
+  mm = NA_SHAPE1(rblapack_vr);
+  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+  howmny = StringValueCStr(rblapack_howmny)[0];
+  if (!NA_IsNArray(rblapack_vl))
+    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+  if (NA_RANK(rblapack_vl) != 2)
+    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+  ldvl = NA_SHAPE0(rblapack_vl);
+  if (NA_SHAPE1(rblapack_vl) != mm)
+    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+  if (!NA_IsNArray(rblapack_s))
+    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+  if (NA_RANK(rblapack_s) != 2)
+    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
+  lds = NA_SHAPE0(rblapack_s);
+  if (NA_SHAPE1(rblapack_s) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
+  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+  s = NA_PTR_TYPE(rblapack_s, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldvl;
+    shape[1] = mm;
+    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+  rblapack_vl = rblapack_vl_out__;
+  vl = vl_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldvr;
+    shape[1] = mm;
+    rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
+  MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
+  rblapack_vr = rblapack_vr_out__;
+  vr = vr_out__;
+  work = ALLOC_N(doublereal, (6*n));
+
+  dtgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
+
+  free(work);
+  rblapack_m = INT2NUM(m);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_dtgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dtgevc", rblapack_dtgevc, -1);
+}

data/ext/dtgex2.c

@@ -0,0 +1,180 @@
+#include "rb_lapack.h"
+
+extern VOID dtgex2_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* j1, integer* n1, integer* n2, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dtgex2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_b;
+  doublereal *b; 
+  VALUE rblapack_q;
+  doublereal *q; 
+  VALUE rblapack_z;
+  doublereal *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__;
+  doublereal *a_out__;
+  VALUE rblapack_b_out__;
+  doublereal *b_out__;
+  VALUE rblapack_q_out__;
+  doublereal *q_out__;
+  VALUE rblapack_z_out__;
+  doublereal *z_out__;
+  doublereal *work;
+
+  integer lda;
+  integer n;
+  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  info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEX2 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 DGGES), 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) DOUBLE PRECISION array, 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) DOUBLE PRECISION array, 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) DOUBLE PRECISION array, dimension (LDQ,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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >=  MAX( 1, 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 DCOPY by calls to DLASET, 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.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [: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_z = argv[5];
+  rblapack_j1 = argv[6];
+  rblapack_n1 = argv[7];
+  rblapack_n2 = 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_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  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);
+  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_DFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, doublereal*);
+  j1 = NUM2INT(rblapack_j1);
+  n2 = NUM2INT(rblapack_n2);
+  wantz = (rblapack_wantz == Qtrue);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (6th 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_DFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, doublereal*);
+  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_DFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, doublereal*);
+  n1 = NUM2INT(rblapack_n1);
+  lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+  MEMCPY(b_out__, b, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+  MEMCPY(q_out__, q, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+  work = ALLOC_N(doublereal, (lwork));
+
+  dtgex2_(&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_dtgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dtgex2", rblapack_dtgex2, -1);
+}

data/ext/dtgexc.c

@@ -0,0 +1,187 @@
+#include "rb_lapack.h"
+
+extern VOID dtgexc_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* ifst, integer* ilst, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dtgexc(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_wantz;
+  logical wantz; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_b;
+  doublereal *b; 
+  VALUE rblapack_q;
+  doublereal *q; 
+  VALUE rblapack_z;
+  doublereal *z; 
+  VALUE rblapack_ifst;
+  integer ifst; 
+  VALUE rblapack_ilst;
+  integer ilst; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_work;
+  doublereal *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+  VALUE rblapack_b_out__;
+  doublereal *b_out__;
+  VALUE rblapack_q_out__;
+  doublereal *q_out__;
+  VALUE rblapack_z_out__;
+  doublereal *z_out__;
+
+  integer lda;
+  integer n;
+  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  work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEXC 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 DGGES), 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDQ,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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 9)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_wantq = argv[0];
+  rblapack_wantz = argv[1];
+  rblapack_a = argv[2];
+  rblapack_b = argv[3];
+  rblapack_q = argv[4];
+  rblapack_z = argv[5];
+  rblapack_ifst = argv[6];
+  rblapack_ilst = argv[7];
+  if (argc == 9) {
+    rblapack_lwork = argv[8];
+  } 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_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  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);
+  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_DFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, doublereal*);
+  ifst = NUM2INT(rblapack_ifst);
+  wantz = (rblapack_wantz == Qtrue);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 2)
+    rb_raise(rb_eArgError, "rank of z (6th 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_DFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, doublereal*);
+  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_DFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, doublereal*);
+  if (rblapack_lwork == Qnil)
+    lwork = n<=1 ? 1 : 4*n+16;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ilst = NUM2INT(rblapack_ilst);
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+  MEMCPY(b_out__, b, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+  MEMCPY(q_out__, q, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+
+  dtgexc_(&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_dtgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dtgexc", rblapack_dtgexc, -1);
+}