ruby-lapack 1.7 → 1.7.1

data/ext/dbdsdc.c

@@ -0,0 +1,151 @@
+#include "rb_lapack.h"
+
+extern VOID dbdsdc_(char* uplo, char* compq, integer* n, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* q, integer* iq, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dbdsdc(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_compq;
+  char compq; 
+  VALUE rblapack_d;
+  doublereal *d; 
+  VALUE rblapack_e;
+  doublereal *e; 
+  VALUE rblapack_u;
+  doublereal *u; 
+  VALUE rblapack_vt;
+  doublereal *vt; 
+  VALUE rblapack_q;
+  doublereal *q; 
+  VALUE rblapack_iq;
+  integer *iq; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_d_out__;
+  doublereal *d_out__;
+  VALUE rblapack_e_out__;
+  doublereal *e_out__;
+  integer c__0;
+  integer c__9;
+  real smlsiz;
+  doublereal *work;
+  integer *iwork;
+
+  integer n;
+  integer ldvt;
+  integer ldu;
+
+  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, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DBDSDC computes the singular value decomposition (SVD) of a real\n*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,\n*  using a divide and conquer method, where S is a diagonal matrix\n*  with non-negative diagonal elements (the singular values of B), and\n*  U and VT are orthogonal matrices of left and right singular vectors,\n*  respectively. DBDSDC can be used to compute all singular values,\n*  and optionally, singular vectors or singular vectors in compact form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See DLASD3 for details.\n*\n*  The code currently calls DLASDQ if singular values only are desired.\n*  However, it can be slightly modified to compute singular values\n*  using the divide and conquer method.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal.\n*          = 'L':  B is lower bidiagonal.\n*\n*  COMPQ   (input) CHARACTER*1\n*          Specifies whether singular vectors are to be computed\n*          as follows:\n*          = 'N':  Compute singular values only;\n*          = 'P':  Compute singular values and compute singular\n*                  vectors in compact form;\n*          = 'I':  Compute singular values and singular vectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the elements of E contain the offdiagonal\n*          elements of the bidiagonal matrix whose SVD is desired.\n*          On exit, E has been destroyed.\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, U contains the left singular vectors\n*             of the bidiagonal matrix.\n*          For other values of COMPQ, U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1.\n*          If singular vectors are desired, then LDU >= max( 1, N ).\n*\n*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, VT' contains the right singular\n*             vectors of the bidiagonal matrix.\n*          For other values of COMPQ, VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1.\n*          If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, Q contains all the DOUBLE PRECISION data in\n*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, Q is not referenced.\n*\n*  IQ      (output) INTEGER array, dimension (LDIQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, IQ contains all INTEGER data in\n*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, IQ is not referenced.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          If COMPQ = 'N' then LWORK >= (4 * N).\n*          If COMPQ = 'P' then LWORK >= (6 * N).\n*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*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:  The algorithm failed to compute a singular value.\n*                The update process of divide and conquer failed.\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*  Changed dimension statement in comment describing E from (N) to\n*  (N-1).  Sven, 17 Feb 05.\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 4 && argc != 4)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_compq = argv[1];
+  rblapack_d = argv[2];
+  rblapack_e = argv[3];
+  if (argc == 4) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_d))
+    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 1)
+    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_d);
+  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+  d = NA_PTR_TYPE(rblapack_d, doublereal*);
+  c__0 = 0;
+  compq = StringValueCStr(rblapack_compq)[0];
+  c__9 = 9;
+  ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
+  if (!NA_IsNArray(rblapack_e))
+    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+  if (NA_RANK(rblapack_e) != 1)
+    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_e) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+  e = NA_PTR_TYPE(rblapack_e, doublereal*);
+  smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
+  ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
+  {
+    na_shape_t shape[2];
+    shape[0] = lsame_(&compq,"I") ? ldu : 0;
+    shape[1] = lsame_(&compq,"I") ? n : 0;
+    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  u = NA_PTR_TYPE(rblapack_u, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = lsame_(&compq,"I") ? ldvt : 0;
+    shape[1] = lsame_(&compq,"I") ? n : 0;
+    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
+    rblapack_q = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  q = NA_PTR_TYPE(rblapack_q, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
+    rblapack_iq = na_make_object(NA_LINT, 1, shape, cNArray);
+  }
+  iq = NA_PTR_TYPE(rblapack_iq, integer*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+  rblapack_d = rblapack_d_out__;
+  d = d_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = n-1;
+    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+  rblapack_e = rblapack_e_out__;
+  e = e_out__;
+  work = ALLOC_N(doublereal, (MAX(1,lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0)));
+  iwork = ALLOC_N(integer, (8*n));
+
+  dbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);
+
+  free(work);
+  free(iwork);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(7, rblapack_u, rblapack_vt, rblapack_q, rblapack_iq, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dbdsdc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dbdsdc", rblapack_dbdsdc, -1);
+}

data/ext/dbdsqr.c

@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublereal* vt, integer* ldvt, doublereal* u, integer* ldu, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dbdsqr(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_nru;
+  integer nru; 
+  VALUE rblapack_d;
+  doublereal *d; 
+  VALUE rblapack_e;
+  doublereal *e; 
+  VALUE rblapack_vt;
+  doublereal *vt; 
+  VALUE rblapack_u;
+  doublereal *u; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_d_out__;
+  doublereal *d_out__;
+  VALUE rblapack_e_out__;
+  doublereal *e_out__;
+  VALUE rblapack_vt_out__;
+  doublereal *vt_out__;
+  VALUE rblapack_u_out__;
+  doublereal *u_out__;
+  VALUE rblapack_c_out__;
+  doublereal *c_out__;
+  doublereal *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.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DBDSQR computes the singular values and, optionally, the right and/or\n*  left singular vectors from the singular value decomposition (SVD) of\n*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n*  zero-shift QR algorithm.  The SVD of B has the form\n* \n*     B = Q * S * P**T\n* \n*  where S is the diagonal matrix of singular values, Q is an orthogonal\n*  matrix of left singular vectors, and P is an orthogonal matrix of\n*  right singular vectors.  If left singular vectors are requested, this\n*  subroutine actually returns U*Q instead of Q, and, if right singular\n*  vectors are requested, this subroutine returns P**T*VT instead of\n*  P**T, for given real input matrices U and VT.  When U and VT are the\n*  orthogonal matrices that reduce a general matrix A to bidiagonal\n*  form:  A = U*B*VT, as computed by DGEBRD, then\n*\n*     A = (U*Q) * S * (P**T*VT)\n*\n*  is the SVD of A.  Optionally, the subroutine may also compute Q**T*C\n*  for a given real input matrix C.\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 (or SIAM J. Sci. Statist. Comput. vol. 11,\n*  no. 5, pp. 873-912, Sept 1990) and\n*  \"Accurate singular values and differential qd algorithms,\" by\n*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n*  Department, University of California at Berkeley, July 1992\n*  for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal;\n*          = 'L':  B is lower bidiagonal.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  NCVT    (input) INTEGER\n*          The number of columns of the matrix VT. NCVT >= 0.\n*\n*  NRU     (input) INTEGER\n*          The number of rows of the matrix U. NRU >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C. NCC >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B in decreasing\n*          order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the N-1 offdiagonal elements of the bidiagonal\n*          matrix B. \n*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n*          will contain the diagonal and superdiagonal elements of a\n*          bidiagonal matrix orthogonally equivalent to the one given\n*          as input.\n*\n*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n*          On entry, an N-by-NCVT matrix VT.\n*          On exit, VT is overwritten by P**T * VT.\n*          Not referenced if NCVT = 0.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.\n*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n*          On entry, an NRU-by-N matrix U.\n*          On exit, U is overwritten by U * Q.\n*          Not referenced if NRU = 0.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= max(1,NRU).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n*          On entry, an N-by-NCC matrix C.\n*          On exit, C is overwritten by Q**T * C.\n*          Not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*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:\n*             if NCVT = NRU = NCC = 0,\n*                = 1, a split was marked by a positive value in E\n*                = 2, current block of Z not diagonalized after 30*N\n*                     iterations (in inner while loop)\n*                = 3, termination criterion of outer while loop not met \n*                     (program created more than N unreduced blocks)\n*             else NCVT = NRU = NCC = 0,\n*                   the algorithm did not converge; D and E contain the\n*                   elements of a bidiagonal matrix which is orthogonally\n*                   similar to the input matrix B;  if INFO = i, i\n*                   elements of E have not converged to zero.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          If it is positive, TOLMUL*EPS is the desired relative\n*             precision in the computed singular values.\n*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n*             desired absolute accuracy in the computed singular\n*             values (corresponds to relative accuracy\n*             abs(TOLMUL*EPS) in the largest singular value.\n*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n*             between 10 (for fast convergence) and .1/EPS\n*             (for there to be some accuracy in the results).\n*          Default is to lose at either one eighth or 2 of the\n*             available decimal digits in each computed singular value\n*             (whichever is smaller).\n*\n*  MAXITR  INTEGER, default = 6\n*          MAXITR controls the maximum number of passes of the\n*          algorithm through its inner loop. The algorithms stops\n*          (and so fails to converge) if the number of passes\n*          through the inner loop exceeds MAXITR*N**2.\n*\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.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 7 && argc != 7)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_nru = argv[1];
+  rblapack_d = argv[2];
+  rblapack_e = argv[3];
+  rblapack_vt = argv[4];
+  rblapack_u = argv[5];
+  rblapack_c = argv[6];
+  if (argc == 7) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_d))
+    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 1)
+    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_d);
+  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_vt))
+    rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
+  if (NA_RANK(rblapack_vt) != 2)
+    rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
+  ldvt = NA_SHAPE0(rblapack_vt);
+  ncvt = NA_SHAPE1(rblapack_vt);
+  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 2)
+    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
+  ldc = NA_SHAPE0(rblapack_c);
+  ncc = 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*);
+  nru = NUM2INT(rblapack_nru);
+  if (!NA_IsNArray(rblapack_u))
+    rb_raise(rb_eArgError, "u (6th argument) must be NArray");
+  if (NA_RANK(rblapack_u) != 2)
+    rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
+  ldu = NA_SHAPE0(rblapack_u);
+  if (NA_SHAPE1(rblapack_u) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
+  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+  u = NA_PTR_TYPE(rblapack_u, doublereal*);
+  if (!NA_IsNArray(rblapack_e))
+    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+  if (NA_RANK(rblapack_e) != 1)
+    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_e) != (n-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+  e = NA_PTR_TYPE(rblapack_e, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n;
+    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+  rblapack_d = rblapack_d_out__;
+  d = d_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = n-1;
+    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+  MEMCPY(e_out__, e, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
+  MEMCPY(vt_out__, vt, doublereal, 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_DFLOAT, 2, shape, cNArray);
+  }
+  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+  MEMCPY(u_out__, u, doublereal, 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_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, (4*n));
+
+  dbdsqr_(&uplo, &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_dbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dbdsqr", rblapack_dbdsqr, -1);
+}

data/ext/ddisna.c

@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID ddisna_(char* job, integer* m, integer* n, doublereal* d, doublereal* sep, integer* info);
+
+
+static VALUE
+rblapack_ddisna(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_job;
+  char job; 
+  VALUE rblapack_n;
+  integer n; 
+  VALUE rblapack_d;
+  doublereal *d; 
+  VALUE rblapack_sep;
+  doublereal *sep; 
+  VALUE rblapack_info;
+  integer info; 
+
+  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  sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DDISNA computes the reciprocal condition numbers for the eigenvectors\n*  of a real symmetric or complex Hermitian matrix or for the left or\n*  right singular vectors of a general m-by-n matrix. The reciprocal\n*  condition number is the 'gap' between the corresponding eigenvalue or\n*  singular value and the nearest other one.\n*\n*  The bound on the error, measured by angle in radians, in the I-th\n*  computed vector is given by\n*\n*         DLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n*  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed\n*  to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of\n*  the error bound.\n*\n*  DDISNA may also be used to compute error bounds for eigenvectors of\n*  the generalized symmetric definite eigenproblem.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies for which problem the reciprocal condition numbers\n*          should be computed:\n*          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;\n*          = 'L':  the left singular vectors of a general matrix;\n*          = 'R':  the right singular vectors of a general matrix.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix. M >= 0.\n*\n*  N       (input) INTEGER\n*          If JOB = 'L' or 'R', the number of columns of the matrix,\n*          in which case N >= 0. Ignored if JOB = 'E'.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n*                              dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The eigenvalues (if JOB = 'E') or singular values (if JOB =\n*          'L' or 'R') of the matrix, in either increasing or decreasing\n*          order. If singular values, they must be non-negative.\n*\n*  SEP     (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n*                               dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The reciprocal condition numbers of the vectors.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 3 && argc != 3)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+  rblapack_job = argv[0];
+  rblapack_n = argv[1];
+  rblapack_d = argv[2];
+  if (argc == 3) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  job = StringValueCStr(rblapack_job)[0];
+  if (!NA_IsNArray(rblapack_d))
+    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 1)
+    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+  m = NA_SHAPE0(rblapack_d);
+  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+  d = NA_PTR_TYPE(rblapack_d, doublereal*);
+  n = NUM2INT(rblapack_n);
+  {
+    na_shape_t shape[1];
+    shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
+    rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
+
+  ddisna_(&job, &m, &n, d, sep, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_sep, rblapack_info);
+}
+
+void
+init_lapack_ddisna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "ddisna", rblapack_ddisna, -1);
+}

data/ext/dgbbrd.c

@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID dgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* pt, integer* ldpt, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgbbrd(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_vect;
+  char vect; 
+  VALUE rblapack_kl;
+  integer kl; 
+  VALUE rblapack_ku;
+  integer ku; 
+  VALUE rblapack_ab;
+  doublereal *ab; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_d;
+  doublereal *d; 
+  VALUE rblapack_e;
+  doublereal *e; 
+  VALUE rblapack_q;
+  doublereal *q; 
+  VALUE rblapack_pt;
+  doublereal *pt; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_ab_out__;
+  doublereal *ab_out__;
+  VALUE rblapack_c_out__;
+  doublereal *c_out__;
+  doublereal *work;
+
+  integer ldab;
+  integer n;
+  integer ldc;
+  integer ncc;
+  integer ldq;
+  integer m;
+  integer ldpt;
+
+  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, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBBRD reduces a real general m-by-n band matrix A to upper\n*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n*  The routine computes B, and optionally forms Q or P', or computes\n*  Q'*C for a given matrix C.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether or not the matrices Q and P' are to be\n*          formed.\n*          = 'N': do not form Q or P';\n*          = 'Q': form Q only;\n*          = 'P': form P' only;\n*          = 'B': form both.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C.  NCC >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals of the matrix A. KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals of the matrix A. KU >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the m-by-n band matrix A, stored in rows 1 to\n*          KL+KU+1. The j-th column of A is stored in the j-th column of\n*          the array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*          On exit, A is overwritten by values generated during the\n*          reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B.\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The superdiagonal elements of the bidiagonal matrix B.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,M)\n*          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n*          If VECT = 'N' or 'P', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n*  PT      (output) DOUBLE PRECISION array, dimension (LDPT,N)\n*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n*          If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n*  LDPT    (input) INTEGER\n*          The leading dimension of the array PT.\n*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)\n*          On entry, an m-by-ncc matrix C.\n*          On exit, C is overwritten by Q'*C.\n*          C is not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [: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_vect = argv[0];
+  rblapack_kl = argv[1];
+  rblapack_ku = argv[2];
+  rblapack_ab = argv[3];
+  rblapack_c = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  vect = StringValueCStr(rblapack_vect)[0];
+  ku = NUM2INT(rblapack_ku);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 2)
+    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+  ldc = NA_SHAPE0(rblapack_c);
+  ncc = 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*);
+  kl = NUM2INT(rblapack_kl);
+  if (!NA_IsNArray(rblapack_ab))
+    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+  if (NA_RANK(rblapack_ab) != 2)
+    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+  ldab = NA_SHAPE0(rblapack_ab);
+  n = NA_SHAPE1(rblapack_ab);
+  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+  ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
+  m = ldab;
+  ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
+  {
+    na_shape_t shape[1];
+    shape[0] = MIN(m,n);
+    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  d = NA_PTR_TYPE(rblapack_d, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = MIN(m,n)-1;
+    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  e = NA_PTR_TYPE(rblapack_e, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldq;
+    shape[1] = m;
+    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  q = NA_PTR_TYPE(rblapack_q, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldpt;
+    shape[1] = n;
+    rblapack_pt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  pt = NA_PTR_TYPE(rblapack_pt, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldab;
+    shape[1] = n;
+    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+  rblapack_ab = rblapack_ab_out__;
+  ab = ab_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = ncc;
+    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, (2*MAX(m,n)));
+
+  dgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
+}
+
+void
+init_lapack_dgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dgbbrd", rblapack_dgbbrd, -1);
+}