ruby-lapack 1.7 → 1.7.1

data/ext/slasd8.c

@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID slasd8_(integer* icompq, integer* k, real* d, real* z, real* vf, real* vl, real* difl, real* difr, integer* lddifr, real* dsigma, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasd8(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_icompq;
+  integer icompq; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_vf;
+  real *vf; 
+  VALUE rblapack_vl;
+  real *vl; 
+  VALUE rblapack_dsigma;
+  real *dsigma; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_difl;
+  real *difl; 
+  VALUE rblapack_difr;
+  real *difr; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_z_out__;
+  real *z_out__;
+  VALUE rblapack_vf_out__;
+  real *vf_out__;
+  VALUE rblapack_vl_out__;
+  real *vl_out__;
+  VALUE rblapack_dsigma_out__;
+  real *dsigma_out__;
+  real *work;
+
+  integer k;
+  integer lddifr;
+
+  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, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD8 finds the square roots of the roots of the secular equation,\n*  as defined by the values in DSIGMA and Z. It makes the appropriate\n*  calls to SLASD4, and stores, for each  element in D, the distance\n*  to its two nearest poles (elements in DSIGMA). It also updates\n*  the arrays VF and VL, the first and last components of all the\n*  right singular vectors of the original bidiagonal matrix.\n*\n*  SLASD8 is called from SLASD6.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          Specifies whether singular vectors are to be computed in\n*          factored form in the calling routine:\n*          = 0: Compute singular values only.\n*          = 1: Compute singular vectors in factored form as well.\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved\n*          by SLASD4.  K >= 1.\n*\n*  D       (output) REAL array, dimension ( K )\n*          On output, D contains the updated singular values.\n*\n*  Z       (input/output) REAL array, dimension ( K )\n*          On entry, the first K elements of this array contain the\n*          components of the deflation-adjusted updating row vector.\n*          On exit, Z is updated.\n*\n*  VF      (input/output) REAL array, dimension ( K )\n*          On entry, VF contains  information passed through DBEDE8.\n*          On exit, VF contains the first K components of the first\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  VL      (input/output) REAL array, dimension ( K )\n*          On entry, VL contains  information passed through DBEDE8.\n*          On exit, VL contains the first K components of the last\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  DIFL    (output) REAL array, dimension ( K )\n*          On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n*  DIFR    (output) REAL array,\n*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n*                   dimension ( K ) if ICOMPQ = 0.\n*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n*          defined and will not be referenced.\n*\n*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n*          normalizing factors for the right singular vector matrix.\n*\n*  LDDIFR  (input) INTEGER\n*          The leading dimension of DIFR, must be at least K.\n*\n*  DSIGMA  (input/output) REAL array, dimension ( K )\n*          On entry, the first K elements of this array contain the old\n*          roots of the deflated updating problem.  These are the poles\n*          of the secular equation.\n*          On exit, the elements of DSIGMA may be very slightly altered\n*          in value.\n*\n*  WORK    (workspace) REAL array, dimension at least 3 * K\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  if INFO = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [: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_icompq = argv[0];
+  rblapack_z = argv[1];
+  rblapack_vf = argv[2];
+  rblapack_vl = argv[3];
+  rblapack_dsigma = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  icompq = NUM2INT(rblapack_icompq);
+  if (!NA_IsNArray(rblapack_vf))
+    rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
+  if (NA_RANK(rblapack_vf) != 1)
+    rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
+  k = NA_SHAPE0(rblapack_vf);
+  if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
+    rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
+  vf = NA_PTR_TYPE(rblapack_vf, real*);
+  if (!NA_IsNArray(rblapack_dsigma))
+    rb_raise(rb_eArgError, "dsigma (5th argument) must be NArray");
+  if (NA_RANK(rblapack_dsigma) != 1)
+    rb_raise(rb_eArgError, "rank of dsigma (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_dsigma) != k)
+    rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vf");
+  if (NA_TYPE(rblapack_dsigma) != NA_SFLOAT)
+    rblapack_dsigma = na_change_type(rblapack_dsigma, NA_SFLOAT);
+  dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 1)
+    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_z) != k)
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vf");
+  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_vl))
+    rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
+  if (NA_RANK(rblapack_vl) != 1)
+    rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_vl) != k)
+    rb_raise(rb_eRuntimeError, "shape 0 of vl must be the same as shape 0 of vf");
+  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+  vl = NA_PTR_TYPE(rblapack_vl, real*);
+  lddifr = k;
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  d = NA_PTR_TYPE(rblapack_d, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  difl = NA_PTR_TYPE(rblapack_difl, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
+    shape[1] = icompq == 1 ? 2 : 0;
+    rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  difr = NA_PTR_TYPE(rblapack_difr, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    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__;
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
+  MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
+  rblapack_vf = rblapack_vf_out__;
+  vf = vf_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+  rblapack_vl = rblapack_vl_out__;
+  vl = vl_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = k;
+    rblapack_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, real*);
+  MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rblapack_dsigma));
+  rblapack_dsigma = rblapack_dsigma_out__;
+  dsigma = dsigma_out__;
+  work = ALLOC_N(real, (3 * k));
+
+  slasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(8, rblapack_d, rblapack_difl, rblapack_difr, rblapack_info, rblapack_z, rblapack_vf, rblapack_vl, rblapack_dsigma);
+}
+
+void
+init_lapack_slasd8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slasd8", rblapack_slasd8, -1);
+}

data/ext/slasda.c

@@ -0,0 +1,221 @@
+#include "rb_lapack.h"
+
+extern VOID slasda_(integer* icompq, integer* smlsiz, integer* n, integer* sqre, real* d, real* e, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slasda(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_icompq;
+  integer icompq; 
+  VALUE rblapack_smlsiz;
+  integer smlsiz; 
+  VALUE rblapack_sqre;
+  integer sqre; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_e;
+  real *e; 
+  VALUE rblapack_u;
+  real *u; 
+  VALUE rblapack_vt;
+  real *vt; 
+  VALUE rblapack_k;
+  integer *k; 
+  VALUE rblapack_difl;
+  real *difl; 
+  VALUE rblapack_difr;
+  real *difr; 
+  VALUE rblapack_z;
+  real *z; 
+  VALUE rblapack_poles;
+  real *poles; 
+  VALUE rblapack_givptr;
+  integer *givptr; 
+  VALUE rblapack_givcol;
+  integer *givcol; 
+  VALUE rblapack_perm;
+  integer *perm; 
+  VALUE rblapack_givnum;
+  real *givnum; 
+  VALUE rblapack_c;
+  real *c; 
+  VALUE rblapack_s;
+  real *s; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_d_out__;
+  real *d_out__;
+  real *work;
+  integer *iwork;
+
+  integer n;
+  integer ldu;
+  integer nlvl;
+  integer ldgcol;
+  integer m;
+
+  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  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using a divide and conquer approach, SLASDA computes the singular\n*  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n*  B with diagonal D and offdiagonal E, where M = N + SQRE. The\n*  algorithm computes the singular values in the SVD B = U * S * VT.\n*  The orthogonal matrices U and VT are optionally computed in\n*  compact form.\n*\n*  A related subroutine, SLASD0, computes the singular values and\n*  the singular vectors in explicit form.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed\n*         in compact form, as follows\n*         = 0: Compute singular values only.\n*         = 1: Compute singular vectors of upper bidiagonal\n*              matrix in compact form.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row dimension of the upper bidiagonal matrix. This is\n*         also the dimension of the main diagonal array D.\n*\n*  SQRE   (input) INTEGER\n*         Specifies the column dimension of the bidiagonal matrix.\n*         = 0: The bidiagonal matrix has column dimension M = N;\n*         = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n*  D      (input/output) REAL array, dimension ( N )\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit D, if INFO = 0, contains its singular values.\n*\n*  E      (input) REAL array, dimension ( M-1 )\n*         Contains the subdiagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  U      (output) REAL array,\n*         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n*         GIVNUM, and Z.\n*\n*  VT     (output) REAL array,\n*         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  K      (output) INTEGER array, dimension ( N ) \n*         if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n*         secular equation on the computation tree.\n*\n*  DIFL   (output) REAL array, dimension ( LDU, NLVL ),\n*         where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n*  DIFR   (output) REAL array,\n*                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n*         record distances between singular values on the I-th\n*         level and singular values on the (I -1)-th level, and\n*         DIFR(1:N, 2 * I ) contains the normalizing factors for\n*         the right singular vector matrix. See SLASD8 for details.\n*\n*  Z      (output) REAL array,\n*                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         The first K elements of Z(1, I) contain the components of\n*         the deflation-adjusted updating row vector for subproblems\n*         on the I-th level.\n*\n*  POLES  (output) REAL array,\n*         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n*         POLES(1, 2*I) contain  the new and old singular values\n*         involved in the secular equations on the I-th level.\n*\n*  GIVPTR (output) INTEGER array,\n*         dimension ( N ) if ICOMPQ = 1, and not referenced if\n*         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n*         the number of Givens rotations performed on the I-th\n*         problem on the computation tree.\n*\n*  GIVCOL (output) INTEGER array,\n*         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n*         of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (output) INTEGER array, dimension ( LDGCOL, NLVL ) \n*         if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n*         permutations done on the I-th level of the computation tree.\n*\n*  GIVNUM (output) REAL array,\n*         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n*         values of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  C      (output) REAL array,\n*         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (output) REAL array, dimension ( N ) if\n*         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n*         and the I-th subproblem is not square, on exit, S( I )\n*         contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  WORK   (workspace) REAL array, dimension\n*         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n*  IWORK  (workspace) INTEGER array, dimension (7*N).\n*\n*  INFO   (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  if INFO = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [: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_icompq = argv[0];
+  rblapack_smlsiz = argv[1];
+  rblapack_sqre = argv[2];
+  rblapack_d = argv[3];
+  rblapack_e = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  icompq = NUM2INT(rblapack_icompq);
+  sqre = NUM2INT(rblapack_sqre);
+  smlsiz = NUM2INT(rblapack_smlsiz);
+  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*);
+  m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
+  nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
+  if (!NA_IsNArray(rblapack_e))
+    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+  if (NA_RANK(rblapack_e) != 1)
+    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_e) != (m-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
+  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+  e = NA_PTR_TYPE(rblapack_e, real*);
+  ldgcol = n;
+  ldu = n;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = MAX(1,smlsiz);
+    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  u = NA_PTR_TYPE(rblapack_u, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = smlsiz+1;
+    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  vt = NA_PTR_TYPE(rblapack_vt, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+    rblapack_k = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  k = NA_PTR_TYPE(rblapack_k, integer*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = nlvl;
+    rblapack_difl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  difl = NA_PTR_TYPE(rblapack_difl, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+    shape[1] = icompq == 1 ? 2 * nlvl : 0;
+    rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  difr = NA_PTR_TYPE(rblapack_difr, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+    shape[1] = icompq == 1 ? nlvl : 0;
+    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  z = NA_PTR_TYPE(rblapack_z, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = 2 * nlvl;
+    rblapack_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  poles = NA_PTR_TYPE(rblapack_poles, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldgcol;
+    shape[1] = 2 * nlvl;
+    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+  }
+  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldgcol;
+    shape[1] = nlvl;
+    rblapack_perm = na_make_object(NA_LINT, 2, shape, cNArray);
+  }
+  perm = NA_PTR_TYPE(rblapack_perm, integer*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = 2 * nlvl;
+    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  c = NA_PTR_TYPE(rblapack_c, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
+    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  s = NA_PTR_TYPE(rblapack_s, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
+  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
+  rblapack_d = rblapack_d_out__;
+  d = d_out__;
+  work = ALLOC_N(real, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
+  iwork = ALLOC_N(integer, (7*n));
+
+  slasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
+
+  free(work);
+  free(iwork);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(15, rblapack_u, rblapack_vt, rblapack_k, rblapack_difl, rblapack_difr, rblapack_z, rblapack_poles, rblapack_givptr, rblapack_givcol, rblapack_perm, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_slasda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slasda", rblapack_slasda, -1);
+}

data/ext/slasdq.c

@@ -0,0 +1,186 @@
+#include "rb_lapack.h"
+
+extern VOID slasdq_(char* uplo, integer* sqre, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, real* vt, integer* ldvt, real* u, integer* ldu, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasdq(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_sqre;
+  integer sqre; 
+  VALUE rblapack_nru;
+  integer nru; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_e;
+  real *e; 
+  VALUE rblapack_vt;
+  real *vt; 
+  VALUE rblapack_u;
+  real *u; 
+  VALUE rblapack_c;
+  real *c; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_d_out__;
+  real *d_out__;
+  VALUE rblapack_e_out__;
+  real *e_out__;
+  VALUE rblapack_vt_out__;
+  real *vt_out__;
+  VALUE rblapack_u_out__;
+  real *u_out__;
+  VALUE rblapack_c_out__;
+  real *c_out__;
+  real *work;
+
+  integer n;
+  integer ldvt;
+  integer ncvt;
+  integer ldu;
+  integer ldc;
+  integer ncc;
+
+  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, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASDQ computes the singular value decomposition (SVD) of a real\n*  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n*  E, accumulating the transformations if desired. Letting B denote\n*  the input bidiagonal matrix, the algorithm computes orthogonal\n*  matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n*  of P). The singular values S are overwritten on D.\n*\n*  The input matrix U  is changed to U  * Q  if desired.\n*  The input matrix VT is changed to P' * VT if desired.\n*  The input matrix C  is changed to Q' * C  if desired.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO  (input) CHARACTER*1\n*        On entry, UPLO specifies whether the input bidiagonal matrix\n*        is upper or lower bidiagonal, and wether it is square are\n*        not.\n*           UPLO = 'U' or 'u'   B is upper bidiagonal.\n*           UPLO = 'L' or 'l'   B is lower bidiagonal.\n*\n*  SQRE  (input) INTEGER\n*        = 0: then the input matrix is N-by-N.\n*        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n*             (N+1)-by-N if UPLU = 'L'.\n*\n*        The bidiagonal matrix has\n*        N = NL + NR + 1 rows and\n*        M = N + SQRE >= N columns.\n*\n*  N     (input) INTEGER\n*        On entry, N specifies the number of rows and columns\n*        in the matrix. N must be at least 0.\n*\n*  NCVT  (input) INTEGER\n*        On entry, NCVT specifies the number of columns of\n*        the matrix VT. NCVT must be at least 0.\n*\n*  NRU   (input) INTEGER\n*        On entry, NRU specifies the number of rows of\n*        the matrix U. NRU must be at least 0.\n*\n*  NCC   (input) INTEGER\n*        On entry, NCC specifies the number of columns of\n*        the matrix C. NCC must be at least 0.\n*\n*  D     (input/output) REAL array, dimension (N)\n*        On entry, D contains the diagonal entries of the\n*        bidiagonal matrix whose SVD is desired. On normal exit,\n*        D contains the singular values in ascending order.\n*\n*  E     (input/output) REAL array.\n*        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n*        On entry, the entries of E contain the offdiagonal entries\n*        of the bidiagonal matrix whose SVD is desired. On normal\n*        exit, E will contain 0. If the algorithm does not converge,\n*        D and E will contain the diagonal and superdiagonal entries\n*        of a bidiagonal matrix orthogonally equivalent to the one\n*        given as input.\n*\n*  VT    (input/output) REAL array, dimension (LDVT, NCVT)\n*        On entry, contains a matrix which on exit has been\n*        premultiplied by P', dimension N-by-NCVT if SQRE = 0\n*        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n*  LDVT  (input) INTEGER\n*        On entry, LDVT specifies the leading dimension of VT as\n*        declared in the calling (sub) program. LDVT must be at\n*        least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n*  U     (input/output) REAL array, dimension (LDU, N)\n*        On entry, contains a  matrix which on exit has been\n*        postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n*        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n*  LDU   (input) INTEGER\n*        On entry, LDU  specifies the leading dimension of U as\n*        declared in the calling (sub) program. LDU must be at\n*        least max( 1, NRU ) .\n*\n*  C     (input/output) REAL array, dimension (LDC, NCC)\n*        On entry, contains an N-by-NCC matrix which on exit\n*        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0\n*        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n*  LDC   (input) INTEGER\n*        On entry, LDC  specifies the leading dimension of C as\n*        declared in the calling (sub) program. LDC must be at\n*        least 1. If NCC is nonzero, LDC must also be at least N.\n*\n*  WORK  (workspace) REAL array, dimension (4*N)\n*        Workspace. Only referenced if one of NCVT, NRU, or NCC is\n*        nonzero, and if N is at least 2.\n*\n*  INFO  (output) INTEGER\n*        On exit, a value of 0 indicates a successful exit.\n*        If INFO < 0, argument number -INFO is illegal.\n*        If INFO > 0, the algorithm did not converge, and INFO\n*        specifies how many superdiagonals did not converge.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [: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_uplo = argv[0];
+  rblapack_sqre = argv[1];
+  rblapack_nru = argv[2];
+  rblapack_d = argv[3];
+  rblapack_e = argv[4];
+  rblapack_vt = argv[5];
+  rblapack_u = argv[6];
+  rblapack_c = argv[7];
+  if (argc == 8) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  nru = NUM2INT(rblapack_nru);
+  if (!NA_IsNArray(rblapack_vt))
+    rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
+  if (NA_RANK(rblapack_vt) != 2)
+    rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
+  ldvt = NA_SHAPE0(rblapack_vt);
+  ncvt = NA_SHAPE1(rblapack_vt);
+  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+  vt = NA_PTR_TYPE(rblapack_vt, real*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 2)
+    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+  ldc = NA_SHAPE0(rblapack_c);
+  ncc = 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*);
+  sqre = NUM2INT(rblapack_sqre);
+  if (!NA_IsNArray(rblapack_u))
+    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+  if (NA_RANK(rblapack_u) != 2)
+    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+  ldu = NA_SHAPE0(rblapack_u);
+  n = NA_SHAPE1(rblapack_u);
+  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+  u = NA_PTR_TYPE(rblapack_u, real*);
+  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 1 of u");
+  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_e))
+    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+  if (NA_RANK(rblapack_e) != 1)
+    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
+    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
+  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+  e = NA_PTR_TYPE(rblapack_e, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
+  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
+  rblapack_d = rblapack_d_out__;
+  d = d_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
+    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+  rblapack_e = rblapack_e_out__;
+  e = e_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldvt;
+    shape[1] = ncvt;
+    rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
+  MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
+  rblapack_vt = rblapack_vt_out__;
+  vt = vt_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldu;
+    shape[1] = n;
+    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+  rblapack_u = rblapack_u_out__;
+  u = u_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = ncc;
+    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, (4*n));
+
+  slasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_slasdq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "slasdq", rblapack_slasdq, -1);
+}