ruby-lapack 1.7 → 1.7.1

data/ext/dlauu2.c

@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dlauu2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dlauu2(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+
+  integer lda;
+  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  info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAUU2 computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-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  info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 2 && argc != 2)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_a = argv[1];
+  if (argc == 2) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+
+  dlauu2_(&uplo, &n, a, &lda, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dlauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlauu2", rblapack_dlauu2, -1);
+}

data/ext/dlauum.c

@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dlauum_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dlauum(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_a_out__;
+  doublereal *a_out__;
+
+  integer lda;
+  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  info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAUUM computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-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  info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 2 && argc != 2)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_a = argv[1];
+  if (argc == 2) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  n = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+  MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+
+  dlauum_(&uplo, &n, a, &lda, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dlauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dlauum", rblapack_dlauum, -1);
+}

data/ext/dopgtr.c

@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID dopgtr_(char* uplo, integer* n, doublereal* ap, doublereal* tau, doublereal* q, integer* ldq, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dopgtr(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_ap;
+  doublereal *ap; 
+  VALUE rblapack_tau;
+  doublereal *tau; 
+  VALUE rblapack_q;
+  doublereal *q; 
+  VALUE rblapack_info;
+  integer info; 
+  doublereal *work;
+
+  integer ldap;
+  integer ldtau;
+  integer ldq;
+  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  q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DOPGTR generates a real orthogonal matrix Q which is defined as the\n*  product of n-1 elementary reflectors H(i) of order n, as returned by\n*  DSPTRD using packed storage:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to DSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to DSPTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The vectors which define the elementary reflectors, as\n*          returned by DSPTRD.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSPTRD.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          The N-by-N orthogonal matrix Q.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)\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  q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [: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_uplo = argv[0];
+  rblapack_ap = argv[1];
+  rblapack_tau = argv[2];
+  if (argc == 3) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_tau))
+    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
+  if (NA_RANK(rblapack_tau) != 1)
+    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
+  ldtau = NA_SHAPE0(rblapack_tau);
+  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
+    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
+  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+  n = ldtau+1;
+  if (!NA_IsNArray(rblapack_ap))
+    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
+  if (NA_RANK(rblapack_ap) != 1)
+    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
+  ldap = NA_SHAPE0(rblapack_ap);
+  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
+    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+  ldq = MAX(1,n);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldq;
+    shape[1] = n;
+    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  q = NA_PTR_TYPE(rblapack_q, doublereal*);
+  work = ALLOC_N(doublereal, (n-1));
+
+  dopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_q, rblapack_info);
+}
+
+void
+init_lapack_dopgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dopgtr", rblapack_dopgtr, -1);
+}

data/ext/dopmtr.c

@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID dopmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublereal* ap, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dopmtr(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_side;
+  char side; 
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_ap;
+  doublereal *ap; 
+  VALUE rblapack_tau;
+  doublereal *tau; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_c_out__;
+  doublereal *c_out__;
+  doublereal *work;
+
+  integer ldc;
+  integer n;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DOPMTR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by DSPTRD using packed\n*  storage:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to DSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to DSPTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension\n*                               (M*(M+1)/2) if SIDE = 'L'\n*                               (N*(N+1)/2) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by DSPTRD.  AP is modified by the routine but\n*          restored on exit.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'\n*                                     or (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSPTRD.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L'\n*                                   (M) if SIDE = 'R'\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  info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, 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_side = argv[0];
+  rblapack_uplo = argv[1];
+  rblapack_trans = argv[2];
+  rblapack_m = argv[3];
+  rblapack_ap = argv[4];
+  rblapack_tau = argv[5];
+  rblapack_c = argv[6];
+  if (argc == 7) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  side = StringValueCStr(rblapack_side)[0];
+  trans = StringValueCStr(rblapack_trans)[0];
+  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);
+  n = NA_SHAPE1(rblapack_c);
+  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, doublereal*);
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  m = NUM2INT(rblapack_m);
+  if (!NA_IsNArray(rblapack_tau))
+    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
+  if (NA_RANK(rblapack_tau) != 1)
+    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_tau) != (m-1))
+    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
+  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
+    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
+  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+  if (!NA_IsNArray(rblapack_ap))
+    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
+  if (NA_RANK(rblapack_ap) != 1)
+    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2))
+    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
+  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
+    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = n;
+    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+  rblapack_c = rblapack_c_out__;
+  c = c_out__;
+  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+  dopmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dopmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dopmtr", rblapack_dopmtr, -1);
+}

data/ext/dorbdb.c

@@ -0,0 +1,232 @@
+#include "rb_lapack.h"
+
+extern VOID dorbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, doublereal* x11, integer* ldx11, doublereal* x12, integer* ldx12, doublereal* x21, integer* ldx21, doublereal* x22, integer* ldx22, doublereal* theta, doublereal* phi, doublereal* taup1, doublereal* taup2, doublereal* tauq1, doublereal* tauq2, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorbdb(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_signs;
+  char signs; 
+  VALUE rblapack_m;
+  integer m; 
+  VALUE rblapack_x11;
+  doublereal *x11; 
+  VALUE rblapack_x12;
+  doublereal *x12; 
+  VALUE rblapack_x21;
+  doublereal *x21; 
+  VALUE rblapack_x22;
+  doublereal *x22; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_theta;
+  doublereal *theta; 
+  VALUE rblapack_phi;
+  doublereal *phi; 
+  VALUE rblapack_taup1;
+  doublereal *taup1; 
+  VALUE rblapack_taup2;
+  doublereal *taup2; 
+  VALUE rblapack_tauq1;
+  doublereal *tauq1; 
+  VALUE rblapack_tauq2;
+  doublereal *tauq2; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_x11_out__;
+  doublereal *x11_out__;
+  VALUE rblapack_x12_out__;
+  doublereal *x12_out__;
+  VALUE rblapack_x21_out__;
+  doublereal *x21_out__;
+  VALUE rblapack_x22_out__;
+  doublereal *x22_out__;
+  doublereal *work;
+
+  integer ldx11;
+  integer q;
+  integer ldx12;
+  integer ldx21;
+  integer ldx22;
+  integer p;
+
+  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  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n*  partitioned orthogonal matrix X:\n*\n*                                  [ B11 | B12 0  0 ]\n*      [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**T\n*  X = [-----------] = [---------] [----------------] [---------]   .\n*      [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]\n*                                  [  0  |  0  0  I ]\n*\n*  X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n*  not the case, then X must be transposed and/or permuted. This can be\n*  done in constant time using the TRANS and SIGNS options. See DORCSD\n*  for details.)\n*\n*  The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n*  (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n*  represented implicitly by Householder vectors.\n*\n*  B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n*  implicitly by angles THETA, PHI.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <=\n*          MIN(P,M-P,M-Q).\n*\n*  X11     (input/output) DOUBLE PRECISION array, dimension (LDX11,Q)\n*          On entry, the top-left block of the orthogonal matrix to be\n*          reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X11) specify reflectors for P1,\n*             the rows of triu(X11,1) specify reflectors for Q1;\n*          else TRANS = 'T', and\n*             the rows of triu(X11) specify reflectors for P1,\n*             the columns of tril(X11,-1) specify reflectors for Q1.\n*\n*  LDX11   (input) INTEGER\n*          The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n*          P; else LDX11 >= Q.\n*\n*  X12     (input/output) DOUBLE PRECISION array, dimension (LDX12,M-Q)\n*          On entry, the top-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X12) specify the first P reflectors for\n*             Q2;\n*          else TRANS = 'T', and\n*             the columns of tril(X12) specify the first P reflectors\n*             for Q2.\n*\n*  LDX12   (input) INTEGER\n*          The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n*          P; else LDX11 >= M-Q.\n*\n*  X21     (input/output) DOUBLE PRECISION array, dimension (LDX21,Q)\n*          On entry, the bottom-left block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X21) specify reflectors for P2;\n*          else TRANS = 'T', and\n*             the rows of triu(X21) specify reflectors for P2.\n*\n*  LDX21   (input) INTEGER\n*          The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n*          M-P; else LDX21 >= Q.\n*\n*  X22     (input/output) DOUBLE PRECISION array, dimension (LDX22,M-Q)\n*          On entry, the bottom-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n*             M-P-Q reflectors for Q2,\n*          else TRANS = 'T', and\n*             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n*             M-P-Q reflectors for P2.\n*\n*  LDX22   (input) INTEGER\n*          The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n*          M-P; else LDX22 >= M-Q.\n*\n*  THETA   (output) DOUBLE PRECISION array, dimension (Q)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  PHI     (output) DOUBLE PRECISION array, dimension (Q-1)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  TAUP1   (output) DOUBLE PRECISION array, dimension (P)\n*          The scalar factors of the elementary reflectors that define\n*          P1.\n*\n*  TAUP2   (output) DOUBLE PRECISION array, dimension (M-P)\n*          The scalar factors of the elementary reflectors that define\n*          P2.\n*\n*  TAUQ1   (output) DOUBLE PRECISION array, dimension (Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q1.\n*\n*  TAUQ2   (output) DOUBLE PRECISION array, dimension (M-Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q2.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= M-Q.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array, and no error\n*          message related to LWORK is issued by XERBLA.\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*  Further Details\n*  ===============\n*\n*  The bidiagonal blocks B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n*  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n*  lower bidiagonal. Every entry in each bidiagonal band is a product\n*  of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n*  [1] or DORCSD for details.\n*\n*  P1, P2, Q1, and Q2 are represented as products of elementary\n*  reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2\n*  using DORGQR and DORGLQ.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  ====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 7 && argc != 8)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+  rblapack_trans = argv[0];
+  rblapack_signs = argv[1];
+  rblapack_m = argv[2];
+  rblapack_x11 = argv[3];
+  rblapack_x12 = argv[4];
+  rblapack_x21 = argv[5];
+  rblapack_x22 = argv[6];
+  if (argc == 8) {
+    rblapack_lwork = argv[7];
+  } else if (rblapack_options != Qnil) {
+    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+  } else {
+    rblapack_lwork = Qnil;
+  }
+
+  trans = StringValueCStr(rblapack_trans)[0];
+  m = NUM2INT(rblapack_m);
+  signs = StringValueCStr(rblapack_signs)[0];
+  if (!NA_IsNArray(rblapack_x11))
+    rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
+  if (NA_RANK(rblapack_x11) != 2)
+    rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
+  ldx11 = NA_SHAPE0(rblapack_x11);
+  q = NA_SHAPE1(rblapack_x11);
+  if (NA_TYPE(rblapack_x11) != NA_DFLOAT)
+    rblapack_x11 = na_change_type(rblapack_x11, NA_DFLOAT);
+  x11 = NA_PTR_TYPE(rblapack_x11, doublereal*);
+  p = ldx11;
+  ldx21 = p;
+  if (!NA_IsNArray(rblapack_x21))
+    rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
+  if (NA_RANK(rblapack_x21) != 2)
+    rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
+  if (NA_SHAPE0(rblapack_x21) != ldx21)
+    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
+  if (NA_SHAPE1(rblapack_x21) != q)
+    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
+  if (NA_TYPE(rblapack_x21) != NA_DFLOAT)
+    rblapack_x21 = na_change_type(rblapack_x21, NA_DFLOAT);
+  x21 = NA_PTR_TYPE(rblapack_x21, doublereal*);
+  if (rblapack_lwork == Qnil)
+    lwork = m-q;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  ldx22 = p;
+  if (!NA_IsNArray(rblapack_x22))
+    rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
+  if (NA_RANK(rblapack_x22) != 2)
+    rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
+  if (NA_SHAPE0(rblapack_x22) != ldx22)
+    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
+  if (NA_SHAPE1(rblapack_x22) != (m-q))
+    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
+  if (NA_TYPE(rblapack_x22) != NA_DFLOAT)
+    rblapack_x22 = na_change_type(rblapack_x22, NA_DFLOAT);
+  x22 = NA_PTR_TYPE(rblapack_x22, doublereal*);
+  ldx12 = p;
+  if (!NA_IsNArray(rblapack_x12))
+    rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
+  if (NA_RANK(rblapack_x12) != 2)
+    rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
+  if (NA_SHAPE0(rblapack_x12) != ldx12)
+    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
+  if (NA_SHAPE1(rblapack_x12) != (m-q))
+    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
+  if (NA_TYPE(rblapack_x12) != NA_DFLOAT)
+    rblapack_x12 = na_change_type(rblapack_x12, NA_DFLOAT);
+  x12 = NA_PTR_TYPE(rblapack_x12, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = q;
+    rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = q-1;
+    rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = p;
+    rblapack_taup1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  taup1 = NA_PTR_TYPE(rblapack_taup1, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = m-p;
+    rblapack_taup2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  taup2 = NA_PTR_TYPE(rblapack_taup2, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = q;
+    rblapack_tauq1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = m-q;
+    rblapack_tauq2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+  }
+  tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublereal*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldx11;
+    shape[1] = q;
+    rblapack_x11_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, doublereal*);
+  MEMCPY(x11_out__, x11, doublereal, NA_TOTAL(rblapack_x11));
+  rblapack_x11 = rblapack_x11_out__;
+  x11 = x11_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldx12;
+    shape[1] = m-q;
+    rblapack_x12_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, doublereal*);
+  MEMCPY(x12_out__, x12, doublereal, NA_TOTAL(rblapack_x12));
+  rblapack_x12 = rblapack_x12_out__;
+  x12 = x12_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldx21;
+    shape[1] = q;
+    rblapack_x21_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, doublereal*);
+  MEMCPY(x21_out__, x21, doublereal, NA_TOTAL(rblapack_x21));
+  rblapack_x21 = rblapack_x21_out__;
+  x21 = x21_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldx22;
+    shape[1] = m-q;
+    rblapack_x22_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+  }
+  x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, doublereal*);
+  MEMCPY(x22_out__, x22, doublereal, NA_TOTAL(rblapack_x22));
+  rblapack_x22 = rblapack_x22_out__;
+  x22 = x22_out__;
+  work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+  dorbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);
+
+  free(work);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22);
+}
+
+void
+init_lapack_dorbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "dorbdb", rblapack_dorbdb, -1);
+}