ruby-lapack 1.6 → 1.7

data/ext/slaqtr.c

@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqtr_(logical* ltran, logical* lreal, integer* n, real* t, integer* ldt, real* b, real* w, real* scale, real* x, real* work, integer* info);
-
-
-static VALUE
-rblapack_slaqtr(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_ltran;
-  logical ltran; 
-  VALUE rblapack_lreal;
-  logical lreal; 
-  VALUE rblapack_t;
-  real *t; 
-  VALUE rblapack_b;
-  real *b; 
-  VALUE rblapack_w;
-  real w; 
-  VALUE rblapack_x;
-  real *x; 
-  VALUE rblapack_scale;
-  real scale; 
-  VALUE rblapack_info;
-  integer info; 
-  VALUE rblapack_x_out__;
-  real *x_out__;
-  real *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.slaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAQTR 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 STRSNA.\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) REAL 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 must\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) REAL 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) REAL\n*          On entry, W is the diagonal element of the matrix B.\n*          If LREAL = .TRUE., W is not referenced.\n*\n*  SCALE   (output) REAL\n*          On exit, SCALE is the scale factor.\n*\n*  X       (input/output) REAL 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) REAL 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 SLALN2 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.slaqtr( 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_SFLOAT)
-    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
-  t = NA_PTR_TYPE(rblapack_t, real*);
-  w = (real)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_SFLOAT)
-    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
-  b = NA_PTR_TYPE(rblapack_b, real*);
-  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_SFLOAT)
-    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
-  x = NA_PTR_TYPE(rblapack_x, real*);
-  {
-    int shape[1];
-    shape[0] = 2*n;
-    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
-  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
-  rblapack_x = rblapack_x_out__;
-  x = x_out__;
-  work = ALLOC_N(real, (n));
-
-  slaqtr_(&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_slaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "slaqtr", rblapack_slaqtr, -1);
-}

data/ext/slar1v.c

@@ -1,173 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slar1v_(integer* n, integer* b1, integer* bn, real* lambda, real* d, real* l, real* ld, real* lld, real* pivmin, real* gaptol, real* z, logical* wantnc, integer* negcnt, real* ztz, real* mingma, integer* r, integer* isuppz, real* nrminv, real* resid, real* rqcorr, real* work);
-
-
-static VALUE
-rblapack_slar1v(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_b1;
-  integer b1; 
-  VALUE rblapack_bn;
-  integer bn; 
-  VALUE rblapack_lambda;
-  real lambda; 
-  VALUE rblapack_d;
-  real *d; 
-  VALUE rblapack_l;
-  real *l; 
-  VALUE rblapack_ld;
-  real *ld; 
-  VALUE rblapack_lld;
-  real *lld; 
-  VALUE rblapack_pivmin;
-  real pivmin; 
-  VALUE rblapack_gaptol;
-  real gaptol; 
-  VALUE rblapack_z;
-  real *z; 
-  VALUE rblapack_wantnc;
-  logical wantnc; 
-  VALUE rblapack_r;
-  integer r; 
-  VALUE rblapack_negcnt;
-  integer negcnt; 
-  VALUE rblapack_ztz;
-  real ztz; 
-  VALUE rblapack_mingma;
-  real mingma; 
-  VALUE rblapack_isuppz;
-  integer *isuppz; 
-  VALUE rblapack_nrminv;
-  real nrminv; 
-  VALUE rblapack_resid;
-  real resid; 
-  VALUE rblapack_rqcorr;
-  real rqcorr; 
-  VALUE rblapack_z_out__;
-  real *z_out__;
-  real *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.slar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAR1V( 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*  SLAR1V 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) REAL            \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) REAL             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) REAL             array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) REAL            \n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) REAL            \n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) REAL             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) REAL            \n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) REAL            \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) REAL            \n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) REAL            \n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) REAL            \n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) REAL             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.slar1v( 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 = (real)NUM2DBL(rblapack_lambda);
-  pivmin = (real)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_SFLOAT)
-    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
-  z = NA_PTR_TYPE(rblapack_z, real*);
-  r = NUM2INT(rblapack_r);
-  bn = NUM2INT(rblapack_bn);
-  gaptol = (real)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_SFLOAT)
-    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
-  d = NA_PTR_TYPE(rblapack_d, real*);
-  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_SFLOAT)
-    rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
-  ld = NA_PTR_TYPE(rblapack_ld, real*);
-  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_SFLOAT)
-    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
-  l = NA_PTR_TYPE(rblapack_l, real*);
-  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_SFLOAT)
-    rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
-  lld = NA_PTR_TYPE(rblapack_lld, real*);
-  {
-    int shape[1];
-    shape[0] = 2;
-    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
-  }
-  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
-  {
-    int shape[1];
-    shape[0] = n;
-    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
-  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
-  rblapack_z = rblapack_z_out__;
-  z = z_out__;
-  work = ALLOC_N(real, (4*n));
-
-  slar1v_(&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_slar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "slar1v", rblapack_slar1v, -1);
-}

data/ext/slar2v.c

@@ -1,149 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slar2v_(integer* n, real* x, real* y, real* z, integer* incx, real* c, real* s, integer* incc);
-
-
-static VALUE
-rblapack_slar2v(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_n;
-  integer n; 
-  VALUE rblapack_x;
-  real *x; 
-  VALUE rblapack_y;
-  real *y; 
-  VALUE rblapack_z;
-  real *z; 
-  VALUE rblapack_incx;
-  integer incx; 
-  VALUE rblapack_c;
-  real *c; 
-  VALUE rblapack_s;
-  real *s; 
-  VALUE rblapack_incc;
-  integer incc; 
-  VALUE rblapack_x_out__;
-  real *x_out__;
-  VALUE rblapack_y_out__;
-  real *y_out__;
-  VALUE rblapack_z_out__;
-  real *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.slar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  SLAR2V 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) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  Y       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector y.\n*\n*  Z       (input/output) REAL 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) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) REAL 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      REAL               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.slar2v( 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_SFLOAT)
-    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
-  x = NA_PTR_TYPE(rblapack_x, real*);
-  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_SFLOAT)
-    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
-  z = NA_PTR_TYPE(rblapack_z, real*);
-  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_SFLOAT)
-    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
-  s = NA_PTR_TYPE(rblapack_s, real*);
-  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_SFLOAT)
-    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
-  y = NA_PTR_TYPE(rblapack_y, real*);
-  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_SFLOAT)
-    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
-  c = NA_PTR_TYPE(rblapack_c, real*);
-  {
-    int shape[1];
-    shape[0] = 1+(n-1)*incx;
-    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
-  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
-  rblapack_x = rblapack_x_out__;
-  x = x_out__;
-  {
-    int shape[1];
-    shape[0] = 1+(n-1)*incx;
-    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__;
-  {
-    int shape[1];
-    shape[0] = 1+(n-1)*incx;
-    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
-  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
-  rblapack_z = rblapack_z_out__;
-  z = z_out__;
-
-  slar2v_(&n, x, y, z, &incx, c, s, &incc);
-
-  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
-}
-
-void
-init_lapack_slar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "slar2v", rblapack_slar2v, -1);
-}

data/ext/slarf.c

@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarf_(char* side, integer* m, integer* n, real* v, integer* incv, real* tau, real* c, integer* ldc, real* work);
-
-
-static VALUE
-rblapack_slarf(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_side;
-  char side; 
-  VALUE rblapack_m;
-  integer m; 
-  VALUE rblapack_v;
-  real *v; 
-  VALUE rblapack_incv;
-  integer incv; 
-  VALUE rblapack_tau;
-  real tau; 
-  VALUE rblapack_c;
-  real *c; 
-  VALUE rblapack_c_out__;
-  real *c_out__;
-  real *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.slarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLARF 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) REAL 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) REAL\n*          The value tau in the representation of H.\n*\n*  C       (input/output) REAL 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) REAL 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.slarf( 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_SFLOAT)
-    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
-  c = NA_PTR_TYPE(rblapack_c, real*);
-  m = NUM2INT(rblapack_m);
-  tau = (real)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_SFLOAT)
-    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
-  v = NA_PTR_TYPE(rblapack_v, real*);
-  {
-    int shape[2];
-    shape[0] = ldc;
-    shape[1] = n;
-    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, 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__;
-  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
-  slarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
-
-  free(work);
-  return rblapack_c;
-}
-
-void
-init_lapack_slarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "slarf", rblapack_slarf, -1);
-}