ruby-lapack 1.7 → 1.7.1

data/ext/slags2.c

@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID slags2_(logical* upper, real* a1, real* a2, real* a3, real* b1, real* b2, real* b3, real* csu, real* snu, real* csv, real* snv, real* csq, real* snq);
+
+
+static VALUE
+rblapack_slags2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_upper;
+  logical upper; 
+  VALUE rblapack_a1;
+  real a1; 
+  VALUE rblapack_a2;
+  real a2; 
+  VALUE rblapack_a3;
+  real a3; 
+  VALUE rblapack_b1;
+  real b1; 
+  VALUE rblapack_b2;
+  real b2; 
+  VALUE rblapack_b3;
+  real b3; 
+  VALUE rblapack_csu;
+  real csu; 
+  VALUE rblapack_snu;
+  real snu; 
+  VALUE rblapack_csv;
+  real csv; 
+  VALUE rblapack_snv;
+  real snv; 
+  VALUE rblapack_csq;
+  real csq; 
+  VALUE rblapack_snq;
+  real snq; 
+
+
+  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  csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n*  Purpose\n*  =======\n*\n*  SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n*  that if ( UPPER ) then\n*\n*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )\n*                        ( 0  A3 )     ( x  x  )\n*  and\n*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )\n*                        ( 0  B3 )     ( x  x  )\n*\n*  or if ( .NOT.UPPER ) then\n*\n*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )\n*                        ( A2 A3 )     ( 0  x  )\n*  and\n*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )\n*                        ( B2 B3 )     ( 0  x  )\n*\n*  The rows of the transformed A and B are parallel, where\n*\n*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )\n*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )\n*\n*  Z' denotes the transpose of Z.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  UPPER   (input) LOGICAL\n*          = .TRUE.: the input matrices A and B are upper triangular.\n*          = .FALSE.: the input matrices A and B are lower triangular.\n*\n*  A1      (input) REAL\n*  A2      (input) REAL\n*  A3      (input) REAL\n*          On entry, A1, A2 and A3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix A.\n*\n*  B1      (input) REAL\n*  B2      (input) REAL\n*  B3      (input) REAL\n*          On entry, B1, B2 and B3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix B.\n*\n*  CSU     (output) REAL\n*  SNU     (output) REAL\n*          The desired orthogonal matrix U.\n*\n*  CSV     (output) REAL\n*  SNV     (output) REAL\n*          The desired orthogonal matrix V.\n*\n*  CSQ     (output) REAL\n*  SNQ     (output) REAL\n*          The desired orthogonal matrix Q.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [: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_upper = argv[0];
+  rblapack_a1 = argv[1];
+  rblapack_a2 = argv[2];
+  rblapack_a3 = argv[3];
+  rblapack_b1 = argv[4];
+  rblapack_b2 = argv[5];
+  rblapack_b3 = argv[6];
+  if (argc == 7) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  upper = (rblapack_upper == Qtrue);
+  a2 = (real)NUM2DBL(rblapack_a2);
+  b1 = (real)NUM2DBL(rblapack_b1);
+  b3 = (real)NUM2DBL(rblapack_b3);
+  a1 = (real)NUM2DBL(rblapack_a1);
+  b2 = (real)NUM2DBL(rblapack_b2);
+  a3 = (real)NUM2DBL(rblapack_a3);
+
+  slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
+
+  rblapack_csu = rb_float_new((double)csu);
+  rblapack_snu = rb_float_new((double)snu);
+  rblapack_csv = rb_float_new((double)csv);
+  rblapack_snv = rb_float_new((double)snv);
+  rblapack_csq = rb_float_new((double)csq);
+  rblapack_snq = rb_float_new((double)snq);
+  return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
+}
+
+void
+init_lapack_slags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slags2", rblapack_slags2, -1);
+}

data/ext/slagtf.c

@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID slagtf_(integer* n, real* a, real* lambda, real* b, real* c, real* tol, real* d, integer* in, integer* info);
+
+
+static VALUE
+rblapack_slagtf(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_lambda;
+  real lambda; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_c;
+  real *c; 
+  VALUE rblapack_tol;
+  real tol; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_in;
+  integer *in; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  real *a_out__;
+  VALUE rblapack_b_out__;
+  real *b_out__;
+  VALUE rblapack_c_out__;
+  real *c_out__;
+
+  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  d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n*  tridiagonal matrix and lambda is a scalar, as\n*\n*     T - lambda*I = PLU,\n*\n*  where P is a permutation matrix, L is a unit lower tridiagonal matrix\n*  with at most one non-zero sub-diagonal elements per column and U is\n*  an upper triangular matrix with at most two non-zero super-diagonal\n*  elements per column.\n*\n*  The factorization is obtained by Gaussian elimination with partial\n*  pivoting and implicit row scaling.\n*\n*  The parameter LAMBDA is included in the routine so that SLAGTF may\n*  be used, in conjunction with SLAGTS, to obtain eigenvectors of T by\n*  inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input/output) REAL array, dimension (N)\n*          On entry, A must contain the diagonal elements of T.\n*\n*          On exit, A is overwritten by the n diagonal elements of the\n*          upper triangular matrix U of the factorization of T.\n*\n*  LAMBDA  (input) REAL\n*          On entry, the scalar lambda.\n*\n*  B       (input/output) REAL array, dimension (N-1)\n*          On entry, B must contain the (n-1) super-diagonal elements of\n*          T.\n*\n*          On exit, B is overwritten by the (n-1) super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  C       (input/output) REAL array, dimension (N-1)\n*          On entry, C must contain the (n-1) sub-diagonal elements of\n*          T.\n*\n*          On exit, C is overwritten by the (n-1) sub-diagonal elements\n*          of the matrix L of the factorization of T.\n*\n*  TOL     (input) REAL\n*          On entry, a relative tolerance used to indicate whether or\n*          not the matrix (T - lambda*I) is nearly singular. TOL should\n*          normally be chose as approximately the largest relative error\n*          in the elements of T. For example, if the elements of T are\n*          correct to about 4 significant figures, then TOL should be\n*          set to about 5*10**(-4). If TOL is supplied as less than eps,\n*          where eps is the relative machine precision, then the value\n*          eps is used in place of TOL.\n*\n*  D       (output) REAL array, dimension (N-2)\n*          On exit, D is overwritten by the (n-2) second super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  IN      (output) INTEGER array, dimension (N)\n*          On exit, IN contains details of the permutation matrix P. If\n*          an interchange occurred at the kth step of the elimination,\n*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n*          returns the smallest positive integer j such that\n*\n*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n*          where norm( A(j) ) denotes the sum of the absolute values of\n*          the jth row of the matrix A. If no such j exists then IN(n)\n*          is returned as zero. If IN(n) is returned as positive, then a\n*          diagonal element of U is small, indicating that\n*          (T - lambda*I) is singular or nearly singular,\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 5 && argc != 5)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+  rblapack_a = argv[0];
+  rblapack_lambda = argv[1];
+  rblapack_b = argv[2];
+  rblapack_c = argv[3];
+  rblapack_tol = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (1th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 1)
+    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
+  n = NA_SHAPE0(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_b))
+    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 1)
+    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_b) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  tol = (real)NUM2DBL(rblapack_tol);
+  lambda = (real)NUM2DBL(rblapack_lambda);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 1)
+    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_c) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n-2;
+    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  d = NA_PTR_TYPE(rblapack_d, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  in = NA_PTR_TYPE(rblapack_in, integer*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, 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[1];
+    shape[0] = n-1;
+    rblapack_b_out__ = na_make_object(NA_SFLOAT, 1, 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[1];
+    shape[0] = n-1;
+    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+  rblapack_c = rblapack_c_out__;
+  c = c_out__;
+
+  slagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(6, rblapack_d, rblapack_in, rblapack_info, rblapack_a, rblapack_b, rblapack_c);
+}
+
+void
+init_lapack_slagtf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slagtf", rblapack_slagtf, -1);
+}

data/ext/slagtm.c

@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID slagtm_(char* trans, integer* n, integer* nrhs, real* alpha, real* dl, real* d, real* du, real* x, integer* ldx, real* beta, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_slagtm(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_alpha;
+  real alpha; 
+  VALUE rblapack_dl;
+  real *dl; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_du;
+  real *du; 
+  VALUE rblapack_x;
+  real *x; 
+  VALUE rblapack_beta;
+  real beta; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_b_out__;
+  real *b_out__;
+
+  integer n;
+  integer ldx;
+  integer nrhs;
+  integer ldb;
+
+  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  b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  SLAGTM performs a matrix-vector product of the form\n*\n*     B := alpha * A * X + beta * B\n*\n*  where A is a tridiagonal matrix of order N, B and X are N by NRHS\n*  matrices, and alpha and beta are real scalars, each of which may be\n*  0., 1., or -1.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  No transpose, B := alpha * A * X + beta * B\n*          = 'T':  Transpose,    B := alpha * A'* X + beta * B\n*          = 'C':  Conjugate transpose = Transpose\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices X and B.\n*\n*  ALPHA   (input) REAL\n*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of T.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of T.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) super-diagonal elements of T.\n*\n*  X       (input) REAL array, dimension (LDX,NRHS)\n*          The N by NRHS matrix X.\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(N,1).\n*\n*  BETA    (input) REAL\n*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 1.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix B.\n*          On exit, B is overwritten by the matrix expression\n*          B := alpha * A * X + beta * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(N,1).\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 8)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_trans = argv[0];
+  rblapack_alpha = argv[1];
+  rblapack_dl = argv[2];
+  rblapack_d = argv[3];
+  rblapack_du = argv[4];
+  rblapack_x = argv[5];
+  rblapack_beta = argv[6];
+  rblapack_b = argv[7];
+  if (argc == 8) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  trans = StringValueCStr(rblapack_trans)[0];
+  if (!NA_IsNArray(rblapack_d))
+    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 1)
+    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_d);
+  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+  d = NA_PTR_TYPE(rblapack_d, real*);
+  if (!NA_IsNArray(rblapack_x))
+    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+  if (NA_RANK(rblapack_x) != 2)
+    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
+  ldx = NA_SHAPE0(rblapack_x);
+  nrhs = NA_SHAPE1(rblapack_x);
+  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+  x = NA_PTR_TYPE(rblapack_x, real*);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != nrhs)
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  alpha = (real)NUM2DBL(rblapack_alpha);
+  if (!NA_IsNArray(rblapack_du))
+    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+  if (NA_RANK(rblapack_du) != 1)
+    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_du) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
+  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
+    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
+  du = NA_PTR_TYPE(rblapack_du, real*);
+  if (!NA_IsNArray(rblapack_dl))
+    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+  if (NA_RANK(rblapack_dl) != 1)
+    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_dl) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
+  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
+    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
+  dl = NA_PTR_TYPE(rblapack_dl, real*);
+  beta = (real)NUM2DBL(rblapack_beta);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldb;
+    shape[1] = nrhs;
+    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__;
+
+  slagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
+
+  return rblapack_b;
+}
+
+void
+init_lapack_slagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slagtm", rblapack_slagtm, -1);
+}

data/ext/slagts.c

@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID slagts_(integer* job, integer* n, real* a, real* b, real* c, real* d, integer* in, real* y, real* tol, integer* info);
+
+
+static VALUE
+rblapack_slagts(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_job;
+  integer job; 
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_c;
+  real *c; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_in;
+  integer *in; 
+  VALUE rblapack_y;
+  real *y; 
+  VALUE rblapack_tol;
+  real tol; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_y_out__;
+  real *y_out__;
+
+  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  info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAGTS may be used to solve one of the systems of equations\n*\n*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,\n*\n*  where T is an n by n tridiagonal matrix, for x, following the\n*  factorization of (T - lambda*I) as\n*\n*     (T - lambda*I) = P*L*U ,\n*\n*  by routine SLAGTF. The choice of equation to be solved is\n*  controlled by the argument JOB, and in each case there is an option\n*  to perturb zero or very small diagonal elements of U, this option\n*  being intended for use in applications such as inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          Specifies the job to be performed by SLAGTS as follows:\n*          =  1: The equations  (T - lambda*I)x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -1: The equations  (T - lambda*I)x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*          =  2: The equations  (T - lambda*I)'x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -2: The equations  (T - lambda*I)'x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input) REAL array, dimension (N)\n*          On entry, A must contain the diagonal elements of U as\n*          returned from SLAGTF.\n*\n*  B       (input) REAL array, dimension (N-1)\n*          On entry, B must contain the first super-diagonal elements of\n*          U as returned from SLAGTF.\n*\n*  C       (input) REAL array, dimension (N-1)\n*          On entry, C must contain the sub-diagonal elements of L as\n*          returned from SLAGTF.\n*\n*  D       (input) REAL array, dimension (N-2)\n*          On entry, D must contain the second super-diagonal elements\n*          of U as returned from SLAGTF.\n*\n*  IN      (input) INTEGER array, dimension (N)\n*          On entry, IN must contain details of the matrix P as returned\n*          from SLAGTF.\n*\n*  Y       (input/output) REAL array, dimension (N)\n*          On entry, the right hand side vector y.\n*          On exit, Y is overwritten by the solution vector x.\n*\n*  TOL     (input/output) REAL\n*          On entry, with  JOB .lt. 0, TOL should be the minimum\n*          perturbation to be made to very small diagonal elements of U.\n*          TOL should normally be chosen as about eps*norm(U), where eps\n*          is the relative machine precision, but if TOL is supplied as\n*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n*          If  JOB .gt. 0  then TOL is not referenced.\n*\n*          On exit, TOL is changed as described above, only if TOL is\n*          non-positive on entry. Otherwise TOL is unchanged.\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -i, the i-th argument had an illegal value\n*          .gt. 0: overflow would occur when computing the INFO(th)\n*                  element of the solution vector x. This can only occur\n*                  when JOB is supplied as positive and either means\n*                  that a diagonal element of U is very small, or that\n*                  the elements of the right-hand side vector y are very\n*                  large.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 8)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_job = argv[0];
+  rblapack_a = argv[1];
+  rblapack_b = argv[2];
+  rblapack_c = argv[3];
+  rblapack_d = argv[4];
+  rblapack_in = argv[5];
+  rblapack_y = argv[6];
+  rblapack_tol = argv[7];
+  if (argc == 8) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  job = NUM2INT(rblapack_job);
+  if (!NA_IsNArray(rblapack_in))
+    rb_raise(rb_eArgError, "in (6th argument) must be NArray");
+  if (NA_RANK(rblapack_in) != 1)
+    rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_in);
+  if (NA_TYPE(rblapack_in) != NA_LINT)
+    rblapack_in = na_change_type(rblapack_in, NA_LINT);
+  in = NA_PTR_TYPE(rblapack_in, integer*);
+  tol = (real)NUM2DBL(rblapack_tol);
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 1)
+    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_a) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of a must be the same as shape 0 of in");
+  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_y))
+    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+  if (NA_RANK(rblapack_y) != 1)
+    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_y) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of in");
+  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+  y = NA_PTR_TYPE(rblapack_y, real*);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 1)
+    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_b) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+  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_d))
+    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 1)
+    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_d) != (n-2))
+    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
+  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+  d = NA_PTR_TYPE(rblapack_d, real*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 1)
+    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_c) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+  rblapack_y = rblapack_y_out__;
+  y = y_out__;
+
+  slagts_(&job, &n, a, b, c, d, in, y, &tol, &info);
+
+  rblapack_info = INT2NUM(info);
+  rblapack_tol = rb_float_new((double)tol);
+  return rb_ary_new3(3, rblapack_info, rblapack_y, rblapack_tol);
+}
+
+void
+init_lapack_slagts(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slagts", rblapack_slagts, -1);
+}