ruby-lapack 1.7 → 1.7.1

data/ext/slaein.c

@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID slaein_(logical* rightv, logical* noinit, integer* n, real* h, integer* ldh, real* wr, real* wi, real* vr, real* vi, real* b, integer* ldb, real* work, real* eps3, real* smlnum, real* bignum, integer* info);
+
+
+static VALUE
+rblapack_slaein(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_rightv;
+  logical rightv; 
+  VALUE rblapack_noinit;
+  logical noinit; 
+  VALUE rblapack_h;
+  real *h; 
+  VALUE rblapack_wr;
+  real wr; 
+  VALUE rblapack_wi;
+  real wi; 
+  VALUE rblapack_vr;
+  real *vr; 
+  VALUE rblapack_vi;
+  real *vi; 
+  VALUE rblapack_eps3;
+  real eps3; 
+  VALUE rblapack_smlnum;
+  real smlnum; 
+  VALUE rblapack_bignum;
+  real bignum; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_vr_out__;
+  real *vr_out__;
+  VALUE rblapack_vi_out__;
+  real *vi_out__;
+  real *b;
+  real *work;
+
+  integer ldh;
+  integer n;
+  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  info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEIN uses inverse iteration to find a right or left eigenvector\n*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n*  matrix H.\n*\n\n*  Arguments\n*  =========\n*\n*  RIGHTV   (input) LOGICAL\n*          = .TRUE. : compute right eigenvector;\n*          = .FALSE.: compute left eigenvector.\n*\n*  NOINIT   (input) LOGICAL\n*          = .TRUE. : no initial vector supplied in (VR,VI).\n*          = .FALSE.: initial vector supplied in (VR,VI).\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) REAL array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  WR      (input) REAL\n*  WI      (input) REAL\n*          The real and imaginary parts of the eigenvalue of H whose\n*          corresponding right or left eigenvector is to be computed.\n*\n*  VR      (input/output) REAL array, dimension (N)\n*  VI      (input/output) REAL array, dimension (N)\n*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n*          a real starting vector for inverse iteration using the real\n*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n*          must contain the real and imaginary parts of a complex\n*          starting vector for inverse iteration using the complex\n*          eigenvalue (WR,WI); otherwise VR and VI need not be set.\n*          On exit, if WI = 0.0 (real eigenvalue), VR contains the\n*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n*          VR and VI contain the real and imaginary parts of the\n*          computed complex eigenvector. The eigenvector is normalized\n*          so that the component of largest magnitude has magnitude 1;\n*          here the magnitude of a complex number (x,y) is taken to be\n*          |x| + |y|.\n*          VI is not referenced if WI = 0.0.\n*\n*  B       (workspace) REAL array, dimension (LDB,N)\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= N+1.\n*\n*  WORK   (workspace) REAL array, dimension (N)\n*\n*  EPS3    (input) REAL\n*          A small machine-dependent value which is used to perturb\n*          close eigenvalues, and to replace zero pivots.\n*\n*  SMLNUM  (input) REAL\n*          A machine-dependent value close to the underflow threshold.\n*\n*  BIGNUM  (input) REAL\n*          A machine-dependent value close to the overflow threshold.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          = 1:  inverse iteration did not converge; VR is set to the\n*                last iterate, and so is VI if WI.ne.0.0.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 10 && argc != 10)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+  rblapack_rightv = argv[0];
+  rblapack_noinit = argv[1];
+  rblapack_h = argv[2];
+  rblapack_wr = argv[3];
+  rblapack_wi = argv[4];
+  rblapack_vr = argv[5];
+  rblapack_vi = argv[6];
+  rblapack_eps3 = argv[7];
+  rblapack_smlnum = argv[8];
+  rblapack_bignum = argv[9];
+  if (argc == 10) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  rightv = (rblapack_rightv == Qtrue);
+  if (!NA_IsNArray(rblapack_h))
+    rb_raise(rb_eArgError, "h (3th argument) must be NArray");
+  if (NA_RANK(rblapack_h) != 2)
+    rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
+  ldh = NA_SHAPE0(rblapack_h);
+  n = NA_SHAPE1(rblapack_h);
+  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+  h = NA_PTR_TYPE(rblapack_h, real*);
+  wi = (real)NUM2DBL(rblapack_wi);
+  if (!NA_IsNArray(rblapack_vi))
+    rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
+  if (NA_RANK(rblapack_vi) != 1)
+    rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_vi) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 1 of h");
+  if (NA_TYPE(rblapack_vi) != NA_SFLOAT)
+    rblapack_vi = na_change_type(rblapack_vi, NA_SFLOAT);
+  vi = NA_PTR_TYPE(rblapack_vi, real*);
+  smlnum = (real)NUM2DBL(rblapack_smlnum);
+  noinit = (rblapack_noinit == Qtrue);
+  if (!NA_IsNArray(rblapack_vr))
+    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+  if (NA_RANK(rblapack_vr) != 1)
+    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_vr) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of vr must be the same as shape 1 of h");
+  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+  vr = NA_PTR_TYPE(rblapack_vr, real*);
+  bignum = (real)NUM2DBL(rblapack_bignum);
+  wr = (real)NUM2DBL(rblapack_wr);
+  ldb = n+1;
+  eps3 = (real)NUM2DBL(rblapack_eps3);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_vr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
+  MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
+  rblapack_vr = rblapack_vr_out__;
+  vr = vr_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_vi_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  vi_out__ = NA_PTR_TYPE(rblapack_vi_out__, real*);
+  MEMCPY(vi_out__, vi, real, NA_TOTAL(rblapack_vi));
+  rblapack_vi = rblapack_vi_out__;
+  vi = vi_out__;
+  b = ALLOC_N(real, (ldb)*(n));
+  work = ALLOC_N(real, (n));
+
+  slaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);
+
+  free(b);
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(3, rblapack_info, rblapack_vr, rblapack_vi);
+}
+
+void
+init_lapack_slaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaein", rblapack_slaein, -1);
+}

data/ext/slaev2.c

@@ -0,0 +1,68 @@
+#include "rb_lapack.h"
+
+extern VOID slaev2_(real* a, real* b, real* c, real* rt1, real* rt2, real* cs1, real* sn1);
+
+
+static VALUE
+rblapack_slaev2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_a;
+  real a; 
+  VALUE rblapack_b;
+  real b; 
+  VALUE rblapack_c;
+  real c; 
+  VALUE rblapack_rt1;
+  real rt1; 
+  VALUE rblapack_rt2;
+  real rt2; 
+  VALUE rblapack_cs1;
+  real cs1; 
+  VALUE rblapack_sn1;
+  real sn1; 
+
+
+  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  rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n*     [  A   B  ]\n*     [  B   C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n*  eigenvector for RT1, giving the decomposition\n*\n*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]\n*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  B       (input) REAL\n*          The (1,2) element and the conjugate of the (2,1) element of\n*          the 2-by-2 matrix.\n*\n*  C       (input) REAL\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1     (output) REAL\n*          The eigenvalue of larger absolute value.\n*\n*  RT2     (output) REAL\n*          The eigenvalue of smaller absolute value.\n*\n*  CS1     (output) REAL\n*  SN1     (output) REAL\n*          The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [: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_a = argv[0];
+  rblapack_b = argv[1];
+  rblapack_c = argv[2];
+  if (argc == 3) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  a = (real)NUM2DBL(rblapack_a);
+  c = (real)NUM2DBL(rblapack_c);
+  b = (real)NUM2DBL(rblapack_b);
+
+  slaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
+
+  rblapack_rt1 = rb_float_new((double)rt1);
+  rblapack_rt2 = rb_float_new((double)rt2);
+  rblapack_cs1 = rb_float_new((double)cs1);
+  rblapack_sn1 = rb_float_new((double)sn1);
+  return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_slaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaev2", rblapack_slaev2, -1);
+}

data/ext/slaexc.c

@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern VOID slaexc_(logical* wantq, integer* n, real* t, integer* ldt, real* q, integer* ldq, integer* j1, integer* n1, integer* n2, real* work, integer* info);
+
+
+static VALUE
+rblapack_slaexc(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_wantq;
+  logical wantq; 
+  VALUE rblapack_t;
+  real *t; 
+  VALUE rblapack_q;
+  real *q; 
+  VALUE rblapack_j1;
+  integer j1; 
+  VALUE rblapack_n1;
+  integer n1; 
+  VALUE rblapack_n2;
+  integer n2; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_t_out__;
+  real *t_out__;
+  VALUE rblapack_q_out__;
+  real *q_out__;
+  real *work;
+
+  integer ldt;
+  integer n;
+  integer ldq;
+
+  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, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n*  an upper quasi-triangular matrix T by an orthogonal similarity\n*  transformation.\n*\n*  T must be in Schur canonical form, that is, block upper triangular\n*  with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n*  has its diagonal elemnts equal and its off-diagonal elements of\n*  opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          = .TRUE. : accumulate the transformation in the matrix Q;\n*          = .FALSE.: do not accumulate the transformation.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) REAL array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          canonical form.\n*          On exit, the updated matrix T, again in Schur canonical form.\n*\n*  LDT     (input)  INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n*          On exit, if WANTQ is .TRUE., the updated matrix Q.\n*          If WANTQ is .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n*  J1      (input) INTEGER\n*          The index of the first row of the first block T11.\n*\n*  N1      (input) INTEGER\n*          The order of the first block T11. N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block T22. N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          = 1: the transformed matrix T would be too far from Schur\n*               form; the blocks are not swapped and T and Q are\n*               unchanged.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 6 && argc != 6)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+  rblapack_wantq = argv[0];
+  rblapack_t = argv[1];
+  rblapack_q = argv[2];
+  rblapack_j1 = argv[3];
+  rblapack_n1 = argv[4];
+  rblapack_n2 = argv[5];
+  if (argc == 6) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  wantq = (rblapack_wantq == Qtrue);
+  if (!NA_IsNArray(rblapack_q))
+    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+  if (NA_RANK(rblapack_q) != 2)
+    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+  ldq = NA_SHAPE0(rblapack_q);
+  n = NA_SHAPE1(rblapack_q);
+  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+  q = NA_PTR_TYPE(rblapack_q, real*);
+  n1 = NUM2INT(rblapack_n1);
+  if (!NA_IsNArray(rblapack_t))
+    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+  if (NA_RANK(rblapack_t) != 2)
+    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+  ldt = NA_SHAPE0(rblapack_t);
+  if (NA_SHAPE1(rblapack_t) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+  t = NA_PTR_TYPE(rblapack_t, real*);
+  n2 = NUM2INT(rblapack_n2);
+  j1 = NUM2INT(rblapack_j1);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldt;
+    shape[1] = n;
+    rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
+  MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
+  rblapack_t = rblapack_t_out__;
+  t = t_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__;
+  work = ALLOC_N(real, (n));
+
+  slaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_slaexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slaexc", rblapack_slaexc, -1);
+}

data/ext/slag2.c

@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID slag2_(real* a, integer* lda, real* b, integer* ldb, real* safmin, real* scale1, real* scale2, real* wr1, real* wr2, real* wi);
+
+
+static VALUE
+rblapack_slag2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_safmin;
+  real safmin; 
+  VALUE rblapack_scale1;
+  real scale1; 
+  VALUE rblapack_scale2;
+  real scale2; 
+  VALUE rblapack_wr1;
+  real wr1; 
+  VALUE rblapack_wr2;
+  real wr2; 
+  VALUE rblapack_wi;
+  real wi; 
+
+  integer lda;
+  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  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n*  Purpose\n*  =======\n*\n*  SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n*  problem  A - w B, with scaling as necessary to avoid over-/underflow.\n*\n*  The scaling factor \"s\" results in a modified eigenvalue equation\n*\n*      s A - w B\n*\n*  where  s  is a non-negative scaling factor chosen so that  w,  w B,\n*  and  s A  do not overflow and, if possible, do not underflow, either.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL array, dimension (LDA, 2)\n*          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm\n*          is less than 1/SAFMIN.  Entries less than\n*          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= 2.\n*\n*  B       (input) REAL array, dimension (LDB, 2)\n*          On entry, the 2 x 2 upper triangular matrix B.  It is\n*          assumed that the one-norm of B is less than 1/SAFMIN.  The\n*          diagonals should be at least sqrt(SAFMIN) times the largest\n*          element of B (in absolute value); if a diagonal is smaller\n*          than that, then  +/- sqrt(SAFMIN) will be used instead of\n*          that diagonal.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= 2.\n*\n*  SAFMIN  (input) REAL\n*          The smallest positive number s.t. 1/SAFMIN does not\n*          overflow.  (This should always be SLAMCH('S') -- it is an\n*          argument in order to avoid having to call SLAMCH frequently.)\n*\n*  SCALE1  (output) REAL\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the first eigenvalue.  If\n*          the eigenvalues are complex, then the eigenvalues are\n*          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the\n*          exponent range of the machine), SCALE1=SCALE2, and SCALE1\n*          will always be positive.  If the eigenvalues are real, then\n*          the first (real) eigenvalue is  WR1 / SCALE1 , but this may\n*          overflow or underflow, and in fact, SCALE1 may be zero or\n*          less than the underflow threshhold if the exact eigenvalue\n*          is sufficiently large.\n*\n*  SCALE2  (output) REAL\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the second eigenvalue.  If\n*          the eigenvalues are complex, then SCALE2=SCALE1.  If the\n*          eigenvalues are real, then the second (real) eigenvalue is\n*          WR2 / SCALE2 , but this may overflow or underflow, and in\n*          fact, SCALE2 may be zero or less than the underflow\n*          threshhold if the exact eigenvalue is sufficiently large.\n*\n*  WR1     (output) REAL\n*          If the eigenvalue is real, then WR1 is SCALE1 times the\n*          eigenvalue closest to the (2,2) element of A B**(-1).  If the\n*          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n*          part of the eigenvalues.\n*\n*  WR2     (output) REAL\n*          If the eigenvalue is real, then WR2 is SCALE2 times the\n*          other eigenvalue.  If the eigenvalue is complex, then\n*          WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n*  WI      (output) REAL\n*          If the eigenvalue is real, then WI is zero.  If the\n*          eigenvalue is complex, then WI is SCALE1 times the imaginary\n*          part of the eigenvalues.  WI will always be non-negative.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [: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_a = argv[0];
+  rblapack_b = argv[1];
+  rblapack_safmin = argv[2];
+  if (argc == 3) {
+  } 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) != 2)
+    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  if (NA_SHAPE1(rblapack_a) != (2))
+    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
+  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, real*);
+  safmin = (real)NUM2DBL(rblapack_safmin);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != (2))
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+
+  slag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);
+
+  rblapack_scale1 = rb_float_new((double)scale1);
+  rblapack_scale2 = rb_float_new((double)scale2);
+  rblapack_wr1 = rb_float_new((double)wr1);
+  rblapack_wr2 = rb_float_new((double)wr2);
+  rblapack_wi = rb_float_new((double)wi);
+  return rb_ary_new3(5, rblapack_scale1, rblapack_scale2, rblapack_wr1, rblapack_wr2, rblapack_wi);
+}
+
+void
+init_lapack_slag2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slag2", rblapack_slag2, -1);
+}

data/ext/slag2d.c

@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID slag2d_(integer* m, integer* n, real* sa, integer* ldsa, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_slag2d(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_sa;
+  real *sa; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_info;
+  integer info; 
+
+  integer ldsa;
+  integer n;
+  integer lda;
+
+  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.slag2d( m, sa, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE\n*  PRECISION matrix, A.\n*\n*  Note that while it is possible to overflow while converting\n*  from double to single, it is not possible to overflow when\n*  converting from single to double.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of lines of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  SA      (input) REAL array, dimension (LDSA,N)\n*          On entry, the M-by-N coefficient matrix SA.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  A       (output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the M-by-N coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.slag2d( m, sa, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 2 && argc != 2)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+  rblapack_m = argv[0];
+  rblapack_sa = argv[1];
+  if (argc == 2) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  m = NUM2INT(rblapack_m);
+  lda = MAX(1,m);
+  if (!NA_IsNArray(rblapack_sa))
+    rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
+  if (NA_RANK(rblapack_sa) != 2)
+    rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
+  ldsa = NA_SHAPE0(rblapack_sa);
+  n = NA_SHAPE1(rblapack_sa);
+  if (NA_TYPE(rblapack_sa) != NA_SFLOAT)
+    rblapack_sa = na_change_type(rblapack_sa, NA_SFLOAT);
+  sa = NA_PTR_TYPE(rblapack_sa, real*);
+  {
+    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*);
+
+  slag2d_(&m, &n, sa, &ldsa, a, &lda, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_slag2d(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slag2d", rblapack_slag2d, -1);
+}