ruby-lapack 1.7 → 1.7.1

data/ext/zlaqsy.c

@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqsy_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqsy(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_a;
+  doublecomplex *a; 
+  VALUE rblapack_s;
+  doublereal *s; 
+  VALUE rblapack_scond;
+  doublereal scond; 
+  VALUE rblapack_amax;
+  doublereal amax; 
+  VALUE rblapack_equed;
+  char equed; 
+  VALUE rblapack_a_out__;
+  doublecomplex *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  equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQSY equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [: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_uplo = argv[0];
+  rblapack_a = argv[1];
+  rblapack_s = argv[2];
+  rblapack_scond = argv[3];
+  rblapack_amax = argv[4];
+  if (argc == 5) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_s))
+    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
+  if (NA_RANK(rblapack_s) != 1)
+    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
+  n = NA_SHAPE0(rblapack_s);
+  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+  s = NA_PTR_TYPE(rblapack_s, doublereal*);
+  amax = NUM2DBL(rblapack_amax);
+  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);
+  if (NA_SHAPE1(rblapack_a) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
+  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+  scond = NUM2DBL(rblapack_scond);
+  {
+    na_shape_t shape[2];
+    shape[0] = lda;
+    shape[1] = n;
+    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
+  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
+  rblapack_a = rblapack_a_out__;
+  a = a_out__;
+
+  zlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
+
+  rblapack_equed = rb_str_new(&equed,1);
+  return rb_ary_new3(2, rblapack_equed, rblapack_a);
+}
+
+void
+init_lapack_zlaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlaqsy", rblapack_zlaqsy, -1);
+}

data/ext/zlar1v.c

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

data/ext/zlar2v.c

@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID zlar2v_(integer* n, doublecomplex* x, doublecomplex* y, doublecomplex* z, integer* incx, doublereal* c, doublecomplex* s, integer* incc);
+
+
+static VALUE
+rblapack_zlar2v(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_n;
+  integer n; 
+  VALUE rblapack_x;
+  doublecomplex *x; 
+  VALUE rblapack_y;
+  doublecomplex *y; 
+  VALUE rblapack_z;
+  doublecomplex *z; 
+  VALUE rblapack_incx;
+  integer incx; 
+  VALUE rblapack_c;
+  doublereal *c; 
+  VALUE rblapack_s;
+  doublecomplex *s; 
+  VALUE rblapack_incc;
+  integer incc; 
+  VALUE rblapack_x_out__;
+  doublecomplex *x_out__;
+  VALUE rblapack_y_out__;
+  doublecomplex *y_out__;
+  VALUE rblapack_z_out__;
+  doublecomplex *z_out__;
+
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  ZLAR2V applies a vector of complex plane rotations with real cosines\n*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n*\n*     (       x(i)  z(i) ) :=\n*     ( conjg(z(i)) y(i) )\n*\n*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )\n*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector x; the elements of x are assumed to be real.\n*\n*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector y; the elements of y are assumed to be real.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      DOUBLE PRECISION   CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n     $                   ZIR\n      COMPLEX*16         SI, T2, T3, T4, ZI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, DCMPLX, DCONJG, DIMAG\n*     ..\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 8)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_n = argv[0];
+  rblapack_x = argv[1];
+  rblapack_y = argv[2];
+  rblapack_z = argv[3];
+  rblapack_incx = argv[4];
+  rblapack_c = argv[5];
+  rblapack_s = argv[6];
+  rblapack_incc = argv[7];
+  if (argc == 8) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  n = NUM2INT(rblapack_n);
+  incx = NUM2INT(rblapack_incx);
+  incc = NUM2INT(rblapack_incc);
+  if (!NA_IsNArray(rblapack_x))
+    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+  if (NA_RANK(rblapack_x) != 1)
+    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
+  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+  if (!NA_IsNArray(rblapack_z))
+    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+  if (NA_RANK(rblapack_z) != 1)
+    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
+  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+  if (!NA_IsNArray(rblapack_s))
+    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
+  if (NA_RANK(rblapack_s) != 1)
+    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
+    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
+  if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
+    rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
+  s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
+  if (!NA_IsNArray(rblapack_y))
+    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
+  if (NA_RANK(rblapack_y) != 1)
+    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
+    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
+  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 1)
+    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
+    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
+  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, doublereal*);
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
+  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
+  rblapack_x = rblapack_x_out__;
+  x = x_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
+  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
+  rblapack_y = rblapack_y_out__;
+  y = y_out__;
+  {
+    na_shape_t shape[1];
+    shape[0] = 1+(n-1)*incx;
+    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+  }
+  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
+  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
+  rblapack_z = rblapack_z_out__;
+  z = z_out__;
+
+  zlar2v_(&n, x, y, z, &incx, c, s, &incc);
+
+  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
+}
+
+void
+init_lapack_zlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlar2v", rblapack_zlar2v, -1);
+}

data/ext/zlarcm.c

@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID zlarcm_(integer* m, integer* n, doublereal* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* rwork);
+
+
+static VALUE
+rblapack_zlarcm(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_a;
+  doublereal *a; 
+  VALUE rblapack_b;
+  doublecomplex *b; 
+  VALUE rblapack_c;
+  doublecomplex *c; 
+  doublereal *rwork;
+
+  integer lda;
+  integer m;
+  integer ldb;
+  integer n;
+  integer ldc;
+
+  VALUE rblapack_options;
+  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+    argc--;
+    rblapack_options = argv[argc];
+    if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarcm( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARCM performs a very simple matrix-matrix multiplication:\n*           C := A * B,\n*  where A is M by M and real; B is M by N and complex;\n*  C is M by N and complex.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A and of the matrix C.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns and rows of the matrix B and\n*          the number of columns of the matrix C.\n*          N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)\n*          A contains the M by M matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >=max(1,M).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)\n*          B contains the M by N matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >=max(1,M).\n*\n*  C       (input) COMPLEX*16 array, dimension (LDC, N)\n*          C contains the M by N matrix C.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >=max(1,M).\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n*\n\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarcm( a, b, [: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_a = argv[0];
+  rblapack_b = argv[1];
+  if (argc == 2) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (1th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  m = 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*);
+  ldc = MAX(1,m);
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  n = NA_SHAPE1(rblapack_b);
+  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = n;
+    rblapack_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+  }
+  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+  rwork = ALLOC_N(doublereal, (2*m*n));
+
+  zlarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
+
+  free(rwork);
+  return rblapack_c;
+}
+
+void
+init_lapack_zlarcm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "zlarcm", rblapack_zlarcm, -1);
+}