ruby-lapack 1.6 → 1.7

data/ext/sgsvj1.c

@@ -1,186 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgsvj1_(char* jobv, integer* m, integer* n, integer* n1, real* a, integer* lda, real* d, real* sva, integer* mv, real* v, integer* ldv, integer* eps, integer* sfmin, real* tol, integer* nsweep, real* work, integer* lwork, integer* info);
-
-
-static VALUE
-rblapack_sgsvj1(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_jobv;
-  char jobv; 
-  VALUE rblapack_m;
-  integer m; 
-  VALUE rblapack_n1;
-  integer n1; 
-  VALUE rblapack_a;
-  real *a; 
-  VALUE rblapack_d;
-  real *d; 
-  VALUE rblapack_sva;
-  real *sva; 
-  VALUE rblapack_mv;
-  integer mv; 
-  VALUE rblapack_v;
-  real *v; 
-  VALUE rblapack_eps;
-  integer eps; 
-  VALUE rblapack_sfmin;
-  integer sfmin; 
-  VALUE rblapack_tol;
-  real tol; 
-  VALUE rblapack_nsweep;
-  integer nsweep; 
-  VALUE rblapack_lwork;
-  integer lwork; 
-  VALUE rblapack_info;
-  integer info; 
-  VALUE rblapack_a_out__;
-  real *a_out__;
-  VALUE rblapack_d_out__;
-  real *d_out__;
-  VALUE rblapack_sva_out__;
-  real *sva_out__;
-  VALUE rblapack_v_out__;
-  real *v_out__;
-  real *work;
-
-  integer lda;
-  integer n;
-  integer ldv;
-
-  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, d, sva, v = NumRu::Lapack.sgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGSVJ1 is called from SGESVJ as a pre-processor and that is its main\n*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n*  it targets only particular pivots and it does not check convergence\n*  (stopping criterion). Few tunning parameters (marked by [TP]) are\n*  available for the implementer.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  SGSVJ1 applies few sweeps of Jacobi rotations in the column space of\n*  the input M-by-N matrix A. The pivot pairs are taken from the (1,2)\n*  off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The\n*  block-entries (tiles) of the (1,2) off-diagonal block are marked by the\n*  [x]'s in the following scheme:\n*\n*     | *   *   * [x] [x] [x]|\n*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.\n*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*\n*  In terms of the columns of A, the first N1 columns are rotated 'against'\n*  the remaining N-N1 columns, trying to increase the angle between the\n*  corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is\n*  tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.\n*  The number of sweeps is given in NSWEEP and the orthogonality threshold\n*  is given in TOL.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n\n*  Arguments\n*  =========\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether the output from this procedure is used\n*          to compute the matrix V:\n*          = 'V': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the N-by-N array V.\n*                (See the description of V.)\n*          = 'A': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the MV-by-N array V.\n*                (See the descriptions of MV and V.)\n*          = 'N': the Jacobi rotations are not accumulated.\n*\n*  M       (input) INTEGER\n*          The number of rows of the input matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the input matrix A.\n*          M >= N >= 0.\n*\n*  N1      (input) INTEGER\n*          N1 specifies the 2 x 2 block partition, the first N1 columns are\n*          rotated 'against' the remaining N-N1 columns of A.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, M-by-N matrix A, such that A*diag(D) represents\n*          the input matrix.\n*          On exit,\n*          A_onexit * D_onexit represents the input matrix A*diag(D)\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, D, TOL and NSWEEP.)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (input/workspace/output) REAL array, dimension (N)\n*          The array D accumulates the scaling factors from the fast scaled\n*          Jacobi rotations.\n*          On entry, A*diag(D) represents the input matrix.\n*          On exit, A_onexit*diag(D_onexit) represents the input matrix\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, A, TOL and NSWEEP.)\n*\n*  SVA     (input/workspace/output) REAL array, dimension (N)\n*          On entry, SVA contains the Euclidean norms of the columns of\n*          the matrix A*diag(D).\n*          On exit, SVA contains the Euclidean norms of the columns of\n*          the matrix onexit*diag(D_onexit).\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then MV is not referenced.\n*\n*  V       (input/output) REAL array, dimension (LDV,N)\n*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V', LDV .GE. N.\n*          If JOBV = 'A', LDV .GE. MV.\n*\n*  EPS     (input) INTEGER\n*          EPS = SLAMCH('Epsilon')\n*\n*  SFMIN   (input) INTEGER\n*          SFMIN = SLAMCH('Safe Minimum')\n*\n*  TOL     (input) REAL\n*          TOL is the threshold for Jacobi rotations. For a pair\n*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n*          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n*\n*  NSWEEP  (input) INTEGER\n*          NSWEEP is the number of sweeps of Jacobi rotations to be\n*          performed.\n*\n*  WORK    (workspace) REAL array, dimension LWORK.\n*\n*  LWORK   (input) INTEGER\n*          LWORK is the dimension of WORK. LWORK .GE. M.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      REAL               ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n     +                   TWO = 2.0E0 )\n*     ..\n*     .. Local Scalars ..\n      REAL               AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,\n     +                   ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,\n     +                   TEMP1, THETA, THSIGN\n      INTEGER            BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,\n     +                   ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,\n     +                   p, PSKIPPED, q, ROWSKIP, SWBAND\n      LOGICAL            APPLV, ROTOK, RSVEC\n*     ..\n*     .. Local Arrays ..\n      REAL               FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT\n*     ..\n*     .. External Functions ..\n      REAL               SDOT, SNRM2\n      INTEGER            ISAMAX\n      LOGICAL            LSAME\n      EXTERNAL           ISAMAX, LSAME, SDOT, SNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP\n*     ..\n\n");
-      return Qnil;
-    }
-    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
-      printf("%s\n", "USAGE:\n  info, a, d, sva, v = NumRu::Lapack.sgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
-      return Qnil;
-    } 
-  } else
-    rblapack_options = Qnil;
-  if (argc != 12 && argc != 13)
-    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
-  rblapack_jobv = argv[0];
-  rblapack_m = argv[1];
-  rblapack_n1 = argv[2];
-  rblapack_a = argv[3];
-  rblapack_d = argv[4];
-  rblapack_sva = argv[5];
-  rblapack_mv = argv[6];
-  rblapack_v = argv[7];
-  rblapack_eps = argv[8];
-  rblapack_sfmin = argv[9];
-  rblapack_tol = argv[10];
-  rblapack_nsweep = argv[11];
-  if (argc == 13) {
-    rblapack_lwork = argv[12];
-  } else if (rblapack_options != Qnil) {
-    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
-  } else {
-    rblapack_lwork = Qnil;
-  }
-
-  jobv = StringValueCStr(rblapack_jobv)[0];
-  n1 = NUM2INT(rblapack_n1);
-  if (!NA_IsNArray(rblapack_d))
-    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
-  if (NA_RANK(rblapack_d) != 1)
-    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
-  n = NA_SHAPE0(rblapack_d);
-  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
-    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
-  d = NA_PTR_TYPE(rblapack_d, real*);
-  mv = NUM2INT(rblapack_mv);
-  eps = NUM2INT(rblapack_eps);
-  tol = (real)NUM2DBL(rblapack_tol);
-  m = NUM2INT(rblapack_m);
-  if (!NA_IsNArray(rblapack_sva))
-    rb_raise(rb_eArgError, "sva (6th argument) must be NArray");
-  if (NA_RANK(rblapack_sva) != 1)
-    rb_raise(rb_eArgError, "rank of sva (6th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_sva) != n)
-    rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 0 of d");
-  if (NA_TYPE(rblapack_sva) != NA_SFLOAT)
-    rblapack_sva = na_change_type(rblapack_sva, NA_SFLOAT);
-  sva = NA_PTR_TYPE(rblapack_sva, real*);
-  sfmin = NUM2INT(rblapack_sfmin);
-  lwork = m;
-  if (!NA_IsNArray(rblapack_a))
-    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
-  if (NA_RANK(rblapack_a) != 2)
-    rb_raise(rb_eArgError, "rank of a (4th 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 d");
-  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
-    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
-  a = NA_PTR_TYPE(rblapack_a, real*);
-  nsweep = NUM2INT(rblapack_nsweep);
-  if (!NA_IsNArray(rblapack_v))
-    rb_raise(rb_eArgError, "v (8th argument) must be NArray");
-  if (NA_RANK(rblapack_v) != 2)
-    rb_raise(rb_eArgError, "rank of v (8th argument) must be %d", 2);
-  ldv = NA_SHAPE0(rblapack_v);
-  if (NA_SHAPE1(rblapack_v) != n)
-    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 0 of d");
-  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
-    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
-  v = NA_PTR_TYPE(rblapack_v, real*);
-  {
-    int shape[2];
-    shape[0] = lda;
-    shape[1] = n;
-    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
-  }
-  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
-  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
-  rblapack_a = rblapack_a_out__;
-  a = a_out__;
-  {
-    int shape[1];
-    shape[0] = n;
-    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
-  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
-  rblapack_d = rblapack_d_out__;
-  d = d_out__;
-  {
-    int shape[1];
-    shape[0] = n;
-    rblapack_sva_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, real*);
-  MEMCPY(sva_out__, sva, real, NA_TOTAL(rblapack_sva));
-  rblapack_sva = rblapack_sva_out__;
-  sva = sva_out__;
-  {
-    int shape[2];
-    shape[0] = ldv;
-    shape[1] = n;
-    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
-  }
-  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
-  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
-  rblapack_v = rblapack_v_out__;
-  v = v_out__;
-  work = ALLOC_N(real, (lwork));
-
-  sgsvj1_(&jobv, &m, &n, &n1, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);
-
-  free(work);
-  rblapack_info = INT2NUM(info);
-  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_d, rblapack_sva, rblapack_v);
-}
-
-void
-init_lapack_sgsvj1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "sgsvj1", rblapack_sgsvj1, -1);
-}

data/ext/sgtcon.c

@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgtcon_(char* norm, integer* n, real* dl, real* d, real* du, real* du2, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
-
-
-static VALUE
-rblapack_sgtcon(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_norm;
-  char norm; 
-  VALUE rblapack_dl;
-  real *dl; 
-  VALUE rblapack_d;
-  real *d; 
-  VALUE rblapack_du;
-  real *du; 
-  VALUE rblapack_du2;
-  real *du2; 
-  VALUE rblapack_ipiv;
-  integer *ipiv; 
-  VALUE rblapack_anorm;
-  real anorm; 
-  VALUE rblapack_rcond;
-  real rcond; 
-  VALUE rblapack_info;
-  integer info; 
-  real *work;
-  integer *iwork;
-
-  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  rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTCON estimates the reciprocal of the condition number of a real\n*  tridiagonal matrix A using the LU factorization as computed by\n*  SGTTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by SGTTRF.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (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  rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm, [: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_norm = argv[0];
-  rblapack_dl = argv[1];
-  rblapack_d = argv[2];
-  rblapack_du = argv[3];
-  rblapack_du2 = argv[4];
-  rblapack_ipiv = argv[5];
-  rblapack_anorm = argv[6];
-  if (argc == 7) {
-  } else if (rblapack_options != Qnil) {
-  } else {
-  }
-
-  norm = StringValueCStr(rblapack_norm)[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_SFLOAT)
-    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
-  d = NA_PTR_TYPE(rblapack_d, real*);
-  if (!NA_IsNArray(rblapack_ipiv))
-    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
-  if (NA_RANK(rblapack_ipiv) != 1)
-    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_ipiv) != n)
-    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
-  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
-    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
-  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
-  if (!NA_IsNArray(rblapack_dl))
-    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
-  if (NA_RANK(rblapack_dl) != 1)
-    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_dl) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
-  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
-    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
-  dl = NA_PTR_TYPE(rblapack_dl, real*);
-  if (!NA_IsNArray(rblapack_du2))
-    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
-  if (NA_RANK(rblapack_du2) != 1)
-    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_du2) != (n-2))
-    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
-  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
-    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
-  du2 = NA_PTR_TYPE(rblapack_du2, real*);
-  if (!NA_IsNArray(rblapack_du))
-    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
-  if (NA_RANK(rblapack_du) != 1)
-    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_du) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
-  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
-    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
-  du = NA_PTR_TYPE(rblapack_du, real*);
-  anorm = (real)NUM2DBL(rblapack_anorm);
-  work = ALLOC_N(real, (2*n));
-  iwork = ALLOC_N(integer, (n));
-
-  sgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, iwork, &info);
-
-  free(work);
-  free(iwork);
-  rblapack_rcond = rb_float_new((double)rcond);
-  rblapack_info = INT2NUM(info);
-  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
-}
-
-void
-init_lapack_sgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "sgtcon", rblapack_sgtcon, -1);
-}

data/ext/sgtrfs.c

@@ -1,209 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgtrfs_(char* trans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* dlf, real* df, real* duf, real* du2, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
-
-
-static VALUE
-rblapack_sgtrfs(int argc, VALUE *argv, VALUE self){
-  VALUE rblapack_trans;
-  char trans; 
-  VALUE rblapack_dl;
-  real *dl; 
-  VALUE rblapack_d;
-  real *d; 
-  VALUE rblapack_du;
-  real *du; 
-  VALUE rblapack_dlf;
-  real *dlf; 
-  VALUE rblapack_df;
-  real *df; 
-  VALUE rblapack_duf;
-  real *duf; 
-  VALUE rblapack_du2;
-  real *du2; 
-  VALUE rblapack_ipiv;
-  integer *ipiv; 
-  VALUE rblapack_b;
-  real *b; 
-  VALUE rblapack_x;
-  real *x; 
-  VALUE rblapack_ferr;
-  real *ferr; 
-  VALUE rblapack_berr;
-  real *berr; 
-  VALUE rblapack_info;
-  integer info; 
-  VALUE rblapack_x_out__;
-  real *x_out__;
-  real *work;
-  integer *iwork;
-
-  integer n;
-  integer ldb;
-  integer nrhs;
-  integer ldx;
-
-  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  ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is tridiagonal, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by SGTTRF.\n*\n*  DF      (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DUF     (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SGTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (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*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
-      return Qnil;
-    }
-    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
-      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n");
-      return Qnil;
-    } 
-  } else
-    rblapack_options = Qnil;
-  if (argc != 11 && argc != 11)
-    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
-  rblapack_trans = argv[0];
-  rblapack_dl = argv[1];
-  rblapack_d = argv[2];
-  rblapack_du = argv[3];
-  rblapack_dlf = argv[4];
-  rblapack_df = argv[5];
-  rblapack_duf = argv[6];
-  rblapack_du2 = argv[7];
-  rblapack_ipiv = argv[8];
-  rblapack_b = argv[9];
-  rblapack_x = argv[10];
-  if (argc == 11) {
-  } else if (rblapack_options != Qnil) {
-  } else {
-  }
-
-  trans = StringValueCStr(rblapack_trans)[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_SFLOAT)
-    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
-  d = NA_PTR_TYPE(rblapack_d, real*);
-  if (!NA_IsNArray(rblapack_df))
-    rb_raise(rb_eArgError, "df (6th argument) must be NArray");
-  if (NA_RANK(rblapack_df) != 1)
-    rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_df) != n)
-    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
-  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
-    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
-  df = NA_PTR_TYPE(rblapack_df, real*);
-  if (!NA_IsNArray(rblapack_ipiv))
-    rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
-  if (NA_RANK(rblapack_ipiv) != 1)
-    rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_ipiv) != n)
-    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
-  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
-    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
-  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
-  if (!NA_IsNArray(rblapack_x))
-    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
-  if (NA_RANK(rblapack_x) != 2)
-    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
-  ldx = NA_SHAPE0(rblapack_x);
-  nrhs = NA_SHAPE1(rblapack_x);
-  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
-    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
-  x = NA_PTR_TYPE(rblapack_x, real*);
-  if (!NA_IsNArray(rblapack_dl))
-    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
-  if (NA_RANK(rblapack_dl) != 1)
-    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_dl) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
-  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
-    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
-  dl = NA_PTR_TYPE(rblapack_dl, real*);
-  if (!NA_IsNArray(rblapack_dlf))
-    rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
-  if (NA_RANK(rblapack_dlf) != 1)
-    rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_dlf) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
-  if (NA_TYPE(rblapack_dlf) != NA_SFLOAT)
-    rblapack_dlf = na_change_type(rblapack_dlf, NA_SFLOAT);
-  dlf = NA_PTR_TYPE(rblapack_dlf, real*);
-  if (!NA_IsNArray(rblapack_du2))
-    rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
-  if (NA_RANK(rblapack_du2) != 1)
-    rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_du2) != (n-2))
-    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
-  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
-    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
-  du2 = NA_PTR_TYPE(rblapack_du2, real*);
-  if (!NA_IsNArray(rblapack_du))
-    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
-  if (NA_RANK(rblapack_du) != 1)
-    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_du) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
-  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
-    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
-  du = NA_PTR_TYPE(rblapack_du, real*);
-  if (!NA_IsNArray(rblapack_b))
-    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
-  if (NA_RANK(rblapack_b) != 2)
-    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
-  ldb = NA_SHAPE0(rblapack_b);
-  if (NA_SHAPE1(rblapack_b) != nrhs)
-    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
-  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
-    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
-  b = NA_PTR_TYPE(rblapack_b, real*);
-  if (!NA_IsNArray(rblapack_duf))
-    rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
-  if (NA_RANK(rblapack_duf) != 1)
-    rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
-  if (NA_SHAPE0(rblapack_duf) != (n-1))
-    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
-  if (NA_TYPE(rblapack_duf) != NA_SFLOAT)
-    rblapack_duf = na_change_type(rblapack_duf, NA_SFLOAT);
-  duf = NA_PTR_TYPE(rblapack_duf, real*);
-  {
-    int shape[1];
-    shape[0] = nrhs;
-    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
-  {
-    int shape[1];
-    shape[0] = nrhs;
-    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
-  }
-  berr = NA_PTR_TYPE(rblapack_berr, real*);
-  {
-    int shape[2];
-    shape[0] = ldx;
-    shape[1] = nrhs;
-    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
-  }
-  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
-  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
-  rblapack_x = rblapack_x_out__;
-  x = x_out__;
-  work = ALLOC_N(real, (3*n));
-  iwork = ALLOC_N(integer, (n));
-
-  sgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
-  free(work);
-  free(iwork);
-  rblapack_info = INT2NUM(info);
-  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
-}
-
-void
-init_lapack_sgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
-  sHelp = sH;
-  sUsage = sU;
-  rblapack_ZERO = zero;
-
-  rb_define_module_function(mLapack, "sgtrfs", rblapack_sgtrfs, -1);
-}