ruby-lapack 1.7 → 1.7.1

data/ext/dlaqtr.c

@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqtr_(logical* ltran, logical* lreal, integer* n, doublereal* t, integer* ldt, doublereal* b, doublereal* w, doublereal* scale, doublereal* x, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlaqtr(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_ltran;
+  logical ltran; 
+  VALUE rblapack_lreal;
+  logical lreal; 
+  VALUE rblapack_t;
+  doublereal *t; 
+  VALUE rblapack_b;
+  doublereal *b; 
+  VALUE rblapack_w;
+  doublereal w; 
+  VALUE rblapack_x;
+  doublereal *x; 
+  VALUE rblapack_scale;
+  doublereal scale; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_x_out__;
+  doublereal *x_out__;
+  doublereal *work;
+
+  integer ldt;
+  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  scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAQTR solves the real quasi-triangular system\n*\n*               op(T)*p = scale*c,               if LREAL = .TRUE.\n*\n*  or the complex quasi-triangular systems\n*\n*             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.\n*\n*  in real arithmetic, where T is upper quasi-triangular.\n*  If LREAL = .FALSE., then the first diagonal block of T must be\n*  1 by 1, B is the specially structured matrix\n*\n*                 B = [ b(1) b(2) ... b(n) ]\n*                     [       w            ]\n*                     [           w        ]\n*                     [              .     ]\n*                     [                 w  ]\n*\n*  op(A) = A or A', A' denotes the conjugate transpose of\n*  matrix A.\n*\n*  On input, X = [ c ].  On output, X = [ p ].\n*                [ d ]                  [ q ]\n*\n*  This subroutine is designed for the condition number estimation\n*  in routine DTRSNA.\n*\n\n*  Arguments\n*  =========\n*\n*  LTRAN   (input) LOGICAL\n*          On entry, LTRAN specifies the option of conjugate transpose:\n*             = .FALSE.,    op(T+i*B) = T+i*B,\n*             = .TRUE.,     op(T+i*B) = (T+i*B)'.\n*\n*  LREAL   (input) LOGICAL\n*          On entry, LREAL specifies the input matrix structure:\n*             = .FALSE.,    the input is complex\n*             = .TRUE.,     the input is real\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of T+i*B. N >= 0.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)\n*          On entry, T contains a matrix in Schur canonical form.\n*          If LREAL = .FALSE., then the first diagonal block of T mu\n*          be 1 by 1.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the matrix T. LDT >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (N)\n*          On entry, B contains the elements to form the matrix\n*          B as described above.\n*          If LREAL = .TRUE., B is not referenced.\n*\n*  W       (input) DOUBLE PRECISION\n*          On entry, W is the diagonal element of the matrix B.\n*          If LREAL = .TRUE., W is not referenced.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, SCALE is the scale factor.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (2*N)\n*          On entry, X contains the right hand side of the system.\n*          On exit, X is overwritten by the solution.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO is set to\n*             0: successful exit.\n*               1: the some diagonal 1 by 1 block has been perturbed by\n*                  a small number SMIN to keep nonsingularity.\n*               2: the some diagonal 2 by 2 block has been perturbed by\n*                  a small number in DLALN2 to keep nonsingularity.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x, [: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_ltran = argv[0];
+  rblapack_lreal = argv[1];
+  rblapack_t = argv[2];
+  rblapack_b = argv[3];
+  rblapack_w = argv[4];
+  rblapack_x = argv[5];
+  if (argc == 6) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  ltran = (rblapack_ltran == Qtrue);
+  if (!NA_IsNArray(rblapack_t))
+    rb_raise(rb_eArgError, "t (3th argument) must be NArray");
+  if (NA_RANK(rblapack_t) != 2)
+    rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
+  ldt = NA_SHAPE0(rblapack_t);
+  n = NA_SHAPE1(rblapack_t);
+  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+  t = NA_PTR_TYPE(rblapack_t, doublereal*);
+  w = NUM2DBL(rblapack_w);
+  lreal = (rblapack_lreal == Qtrue);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 1)
+    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_b) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
+  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, doublereal*);
+  if (!NA_IsNArray(rblapack_x))
+    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+  if (NA_RANK(rblapack_x) != 1)
+    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_x) != (2*n))
+    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
+  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+  x = NA_PTR_TYPE(rblapack_x, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = 2*n;
+    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+  rblapack_x = rblapack_x_out__;
+  x = x_out__;
+  work = ALLOC_N(doublereal, (n));
+
+  dlaqtr_(&ltran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);
+
+  free(work);
+  rblapack_scale = rb_float_new((double)scale);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_dlaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlaqtr", rblapack_dlaqtr, -1);
+}

data/ext/dlar1v.c

@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID dlar1v_(integer* n, integer* b1, integer* bn, doublereal* lambda, doublereal* d, doublereal* l, doublereal* ld, doublereal* lld, doublereal* pivmin, doublereal* gaptol, doublereal* z, logical* wantnc, integer* negcnt, doublereal* ztz, doublereal* mingma, integer* r, integer* isuppz, doublereal* nrminv, doublereal* resid, doublereal* rqcorr, doublereal* work);
+
+
+static VALUE
+rblapack_dlar1v(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_b1;
+  integer b1; 
+  VALUE rblapack_bn;
+  integer bn; 
+  VALUE rblapack_lambda;
+  doublereal lambda; 
+  VALUE rblapack_d;
+  doublereal *d; 
+  VALUE rblapack_l;
+  doublereal *l; 
+  VALUE rblapack_ld;
+  doublereal *ld; 
+  VALUE rblapack_lld;
+  doublereal *lld; 
+  VALUE rblapack_pivmin;
+  doublereal pivmin; 
+  VALUE rblapack_gaptol;
+  doublereal gaptol; 
+  VALUE rblapack_z;
+  doublereal *z; 
+  VALUE rblapack_wantnc;
+  logical wantnc; 
+  VALUE rblapack_r;
+  integer r; 
+  VALUE rblapack_negcnt;
+  integer negcnt; 
+  VALUE rblapack_ztz;
+  doublereal ztz; 
+  VALUE rblapack_mingma;
+  doublereal mingma; 
+  VALUE rblapack_isuppz;
+  integer *isuppz; 
+  VALUE rblapack_nrminv;
+  doublereal nrminv; 
+  VALUE rblapack_resid;
+  doublereal resid; 
+  VALUE rblapack_rqcorr;
+  doublereal rqcorr; 
+  VALUE rblapack_z_out__;
+  doublereal *z_out__;
+  doublereal *work;
+
+  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  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLAR1V computes the (scaled) r-th column of the inverse of\n*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n*  L D L^T - sigma I. When sigma is close to an eigenvalue, the\n*  computed vector is an accurate eigenvector. Usually, r corresponds\n*  to the index where the eigenvector is largest in magnitude.\n*  The following steps accomplish this computation :\n*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,\n*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n*  (c) Computation of the diagonal elements of the inverse of\n*      L D L^T - sigma I by combining the above transforms, and choosing\n*      r as the index where the diagonal of the inverse is (one of the)\n*      largest in magnitude.\n*  (d) Computation of the (scaled) r-th column of the inverse using the\n*      twisted factorization obtained by combining the top part of the\n*      the stationary and the bottom part of the progressive transform.\n*\n\n*  Arguments\n*  =========\n*\n*  N        (input) INTEGER\n*           The order of the matrix L D L^T.\n*\n*  B1       (input) INTEGER\n*           First index of the submatrix of L D L^T.\n*\n*  BN       (input) INTEGER\n*           Last index of the submatrix of L D L^T.\n*\n*  LAMBDA    (input) DOUBLE PRECISION\n*           The shift. In order to compute an accurate eigenvector,\n*           LAMBDA should be a good approximation to an eigenvalue\n*           of L D L^T.\n*\n*  L        (input) DOUBLE PRECISION array, dimension (N-1)\n*           The (n-1) subdiagonal elements of the unit bidiagonal matrix\n*           L, in elements 1 to N-1.\n*\n*  D        (input) DOUBLE PRECISION array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) DOUBLE PRECISION\n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) DOUBLE PRECISION\n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) DOUBLE PRECISION array, dimension (N)\n*           On input, all entries of Z must be set to 0.\n*           On output, Z contains the (scaled) r-th column of the\n*           inverse. The scaling is such that Z(R) equals 1.\n*\n*  WANTNC   (input) LOGICAL\n*           Specifies whether NEGCNT has to be computed.\n*\n*  NEGCNT   (output) INTEGER\n*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n*  ZTZ      (output) DOUBLE PRECISION\n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) DOUBLE PRECISION\n*           The reciprocal of the largest (in magnitude) diagonal\n*           element of the inverse of L D L^T - sigma I.\n*\n*  R        (input/output) INTEGER\n*           The twist index for the twisted factorization used to\n*           compute Z.\n*           On input, 0 <= R <= N. If R is input as 0, R is set to\n*           the index where (L D L^T - sigma I)^{-1} is largest\n*           in magnitude. If 1 <= R <= N, R is unchanged.\n*           On output, R contains the twist index used to compute Z.\n*           Ideally, R designates the position of the maximum entry in the\n*           eigenvector.\n*\n*  ISUPPZ   (output) INTEGER array, dimension (2)\n*           The support of the vector in Z, i.e., the vector Z is\n*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n*  NRMINV   (output) DOUBLE PRECISION\n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) DOUBLE PRECISION\n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) DOUBLE PRECISION\n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 12 && argc != 12)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
+  rblapack_b1 = argv[0];
+  rblapack_bn = argv[1];
+  rblapack_lambda = argv[2];
+  rblapack_d = argv[3];
+  rblapack_l = argv[4];
+  rblapack_ld = argv[5];
+  rblapack_lld = argv[6];
+  rblapack_pivmin = argv[7];
+  rblapack_gaptol = argv[8];
+  rblapack_z = argv[9];
+  rblapack_wantnc = argv[10];
+  rblapack_r = argv[11];
+  if (argc == 12) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  b1 = NUM2INT(rblapack_b1);
+  lambda = NUM2DBL(rblapack_lambda);
+  pivmin = NUM2DBL(rblapack_pivmin);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 1)
+    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_z);
+  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+  z = NA_PTR_TYPE(rblapack_z, doublereal*);
+  r = NUM2INT(rblapack_r);
+  bn = NUM2INT(rblapack_bn);
+  gaptol = NUM2DBL(rblapack_gaptol);
+  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);
+  if (NA_SHAPE0(rblapack_d) != n)
+    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
+  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+  d = NA_PTR_TYPE(rblapack_d, doublereal*);
+  if (!NA_IsNArray(rblapack_ld))
+    rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
+  if (NA_RANK(rblapack_ld) != 1)
+    rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_ld) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
+  if (NA_TYPE(rblapack_ld) != NA_DFLOAT)
+    rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT);
+  ld = NA_PTR_TYPE(rblapack_ld, doublereal*);
+  wantnc = (rblapack_wantnc == Qtrue);
+  if (!NA_IsNArray(rblapack_l))
+    rb_raise(rb_eArgError, "l (5th argument) must be NArray");
+  if (NA_RANK(rblapack_l) != 1)
+    rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_l) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
+  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
+    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
+  l = NA_PTR_TYPE(rblapack_l, doublereal*);
+  if (!NA_IsNArray(rblapack_lld))
+    rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
+  if (NA_RANK(rblapack_lld) != 1)
+    rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_lld) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
+  if (NA_TYPE(rblapack_lld) != NA_DFLOAT)
+    rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT);
+  lld = NA_PTR_TYPE(rblapack_lld, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = 2;
+    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, 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, (4*n));
+
+  dlar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);
+
+  free(work);
+  rblapack_negcnt = INT2NUM(negcnt);
+  rblapack_ztz = rb_float_new((double)ztz);
+  rblapack_mingma = rb_float_new((double)mingma);
+  rblapack_nrminv = rb_float_new((double)nrminv);
+  rblapack_resid = rb_float_new((double)resid);
+  rblapack_rqcorr = rb_float_new((double)rqcorr);
+  rblapack_r = INT2NUM(r);
+  return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r);
+}
+
+void
+init_lapack_dlar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlar1v", rblapack_dlar1v, -1);
+}

data/ext/dlar2v.c

@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID dlar2v_(integer* n, doublereal* x, doublereal* y, doublereal* z, integer* incx, doublereal* c, doublereal* s, integer* incc);
+
+
+static VALUE
+rblapack_dlar2v(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_n;
+  integer n; 
+  VALUE rblapack_x;
+  doublereal *x; 
+  VALUE rblapack_y;
+  doublereal *y; 
+  VALUE rblapack_z;
+  doublereal *z; 
+  VALUE rblapack_incx;
+  integer incx; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_s;
+  doublereal *s; 
+  VALUE rblapack_incc;
+  integer incc; 
+  VALUE rblapack_x_out__;
+  doublereal *x_out__;
+  VALUE rblapack_y_out__;
+  doublereal *y_out__;
+  VALUE rblapack_z_out__;
+  doublereal *z_out__;
+
+
+  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  x, y, z = NumRu::Lapack.dlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  DLAR2V applies a vector of real plane rotations from both sides to\n*  a sequence of 2-by-2 real symmetric matrices, defined by the elements\n*  of the vectors x, y and z. For i = 1,2,...,n\n*\n*     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )\n*     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  Y       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector y.\n*\n*  Z       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      DOUBLE PRECISION   CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n*     ..\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.dlar2v( n, x, y, z, incx, c, s, incc, [: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_n = argv[0];
+  rblapack_x = argv[1];
+  rblapack_y = argv[2];
+  rblapack_z = argv[3];
+  rblapack_incx = argv[4];
+  rblapack_c = argv[5];
+  rblapack_s = argv[6];
+  rblapack_incc = argv[7];
+  if (argc == 8) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  n = NUM2INT(rblapack_n);
+  incx = NUM2INT(rblapack_incx);
+  incc = NUM2INT(rblapack_incc);
+  if (!NA_IsNArray(rblapack_x))
+    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+  if (NA_RANK(rblapack_x) != 1)
+    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
+  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+  x = NA_PTR_TYPE(rblapack_x, doublereal*);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 1)
+    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
+  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_s))
+    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
+  if (NA_RANK(rblapack_s) != 1)
+    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
+    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
+  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+  s = NA_PTR_TYPE(rblapack_s, doublereal*);
+  if (!NA_IsNArray(rblapack_y))
+    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
+  if (NA_RANK(rblapack_y) != 1)
+    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
+  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+  y = NA_PTR_TYPE(rblapack_y, doublereal*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 1)
+    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
+    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
+  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+  rblapack_x = rblapack_x_out__;
+  x = x_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+  rblapack_y = rblapack_y_out__;
+  y = y_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+  dlar2v_(&n, x, y, z, &incx, c, s, &incc);
+
+  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
+}
+
+void
+init_lapack_dlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlar2v", rblapack_dlar2v, -1);
+}

data/ext/dlarf.c

@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dlarf_(char* side, integer* m, integer* n, doublereal* v, integer* incv, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);
+
+
+static VALUE
+rblapack_dlarf(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_side;
+  char side; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_v;
+  doublereal *v; 
+  VALUE rblapack_incv;
+  integer incv; 
+  VALUE rblapack_tau;
+  doublereal tau; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_c_out__;
+  doublereal *c_out__;
+  doublereal *work;
+
+  integer ldc;
+  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  c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLARF applies a real elementary reflector H to a real m by n matrix\n*  C, from either the left or the right. H is represented in the form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) DOUBLE PRECISION array, dimension\n*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of H. V is not used if\n*          TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) DOUBLE PRECISION\n*          The value tau in the representation of H.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [: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_side = argv[0];
+  rblapack_m = argv[1];
+  rblapack_v = argv[2];
+  rblapack_incv = argv[3];
+  rblapack_tau = argv[4];
+  rblapack_c = argv[5];
+  if (argc == 6) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  side = StringValueCStr(rblapack_side)[0];
+  incv = NUM2INT(rblapack_incv);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 2)
+    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+  ldc = NA_SHAPE0(rblapack_c);
+  n = NA_SHAPE1(rblapack_c);
+  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, doublereal*);
+  m = NUM2INT(rblapack_m);
+  tau = NUM2DBL(rblapack_tau);
+  if (!NA_IsNArray(rblapack_v))
+    rb_raise(rb_eArgError, "v (3th argument) must be NArray");
+  if (NA_RANK(rblapack_v) != 1)
+    rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+  v = NA_PTR_TYPE(rblapack_v, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = n;
+    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+  rblapack_c = rblapack_c_out__;
+  c = c_out__;
+  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+  dlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
+
+  free(work);
+  return rblapack_c;
+}
+
+void
+init_lapack_dlarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlarf", rblapack_dlarf, -1);
+}