ruby-lapack 1.7 → 1.7.1

data/ext/stgsyl.c

@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID stgsyl_(char* trans, integer* ijob, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* d, integer* ldd, real* e, integer* lde, real* f, integer* ldf, real* scale, real* dif, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stgsyl(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_ijob;
+  integer ijob; 
+  VALUE rblapack_a;
+  real *a; 
+  VALUE rblapack_b;
+  real *b; 
+  VALUE rblapack_c;
+  real *c; 
+  VALUE rblapack_d;
+  real *d; 
+  VALUE rblapack_e;
+  real *e; 
+  VALUE rblapack_f;
+  real *f; 
+  VALUE rblapack_lwork;
+  integer lwork; 
+  VALUE rblapack_scale;
+  real scale; 
+  VALUE rblapack_dif;
+  real dif; 
+  VALUE rblapack_work;
+  real *work; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_c_out__;
+  real *c_out__;
+  VALUE rblapack_f_out__;
+  real *f_out__;
+  integer *iwork;
+
+  integer lda;
+  integer m;
+  integer ldb;
+  integer n;
+  integer ldc;
+  integer ldd;
+  integer lde;
+  integer ldf;
+
+  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  scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSYL solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C                 (1)\n*              D * R - L * E = scale * F\n*\n*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n*  respectively, with real entries. (A, D) and (B, E) must be in\n*  generalized (real) Schur canonical form, i.e. A, B are upper quasi\n*  triangular and D, E are upper triangular.\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n*  scaling factor chosen to avoid overflow.\n*\n*  In matrix notation (1) is equivalent to solve  Zx = scale b, where\n*  Z is defined as\n*\n*             Z = [ kron(In, A)  -kron(B', Im) ]         (2)\n*                 [ kron(In, D)  -kron(E', Im) ].\n*\n*  Here Ik is the identity matrix of size k and X' is the transpose of\n*  X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n*  If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,\n*  which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * (-F)\n*\n*  This case (TRANS = 'T') is used to compute an one-norm-based estimate\n*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n*  and (B,E), using SLACON.\n*\n*  If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate\n*  of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n*  reciprocal of the smallest singular value of Z. See [1-2] for more\n*  information.\n*\n*  This is a level 3 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T', solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*           =0: solve (1) only.\n*           =1: The functionality of 0 and 3.\n*           =2: The functionality of 0 and 4.\n*           =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               (look ahead strategy IJOB  = 1 is used).\n*           =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               ( SGECON on sub-systems is used ).\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          The order of the matrices A and D, and the row dimension of\n*          the matrices C, F, R and L.\n*\n*  N       (input) INTEGER\n*          The order of the matrices B and E, and the column dimension\n*          of the matrices C, F, R and L.\n*\n*  A       (input) REAL array, dimension (LDA, M)\n*          The upper quasi triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1, M).\n*\n*  B       (input) REAL array, dimension (LDB, N)\n*          The upper quasi triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1, N).\n*\n*  C       (input/output) REAL array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1, M).\n*\n*  D       (input) REAL array, dimension (LDD, M)\n*          The upper triangular matrix D.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the array D. LDD >= max(1, M).\n*\n*  E       (input) REAL array, dimension (LDE, N)\n*          The upper triangular matrix E.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the array E. LDE >= max(1, N).\n*\n*  F       (input/output) REAL array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1, M).\n*\n*  DIF     (output) REAL\n*          On exit DIF is the reciprocal of a lower bound of the\n*          reciprocal of the Dif-function, i.e. DIF is an upper bound of\n*          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n*          IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n*\n*  SCALE   (output) REAL\n*          On exit SCALE is the scaling factor in (1) or (3).\n*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n*          to a slightly perturbed system but the input matrices A, B, D\n*          and E have not been changed. If SCALE = 0, C and F hold the\n*          solutions R and L, respectively, to the homogeneous system\n*          with C = F = 0. Normally, SCALE = 1.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK > = 1.\n*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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*  IWORK   (workspace) INTEGER array, dimension (M+N+6)\n*\n*  INFO    (output) INTEGER\n*            =0: successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: (A, D) and (B, E) have common or close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n*      Appl., 15(4):1045-1060, 1994\n*\n*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n*      Condition Estimators for Solving the Generalized Sylvester\n*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n*      July 1989, pp 745-751.\n*\n*  =====================================================================\n*  Replaced various illegal calls to SCOPY by calls to SLASET.\n*  Sven Hammarling, 1/5/02.\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 8 && argc != 9)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+  rblapack_trans = argv[0];
+  rblapack_ijob = argv[1];
+  rblapack_a = argv[2];
+  rblapack_b = argv[3];
+  rblapack_c = argv[4];
+  rblapack_d = argv[5];
+  rblapack_e = argv[6];
+  rblapack_f = argv[7];
+  if (argc == 9) {
+    rblapack_lwork = argv[8];
+  } 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];
+  if (!NA_IsNArray(rblapack_a))
+    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
+  if (NA_RANK(rblapack_a) != 2)
+    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
+  lda = NA_SHAPE0(rblapack_a);
+  m = NA_SHAPE1(rblapack_a);
+  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+  a = NA_PTR_TYPE(rblapack_a, real*);
+  if (!NA_IsNArray(rblapack_c))
+    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+  if (NA_RANK(rblapack_c) != 2)
+    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+  ldc = NA_SHAPE0(rblapack_c);
+  n = NA_SHAPE1(rblapack_c);
+  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+  c = NA_PTR_TYPE(rblapack_c, real*);
+  if (!NA_IsNArray(rblapack_e))
+    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
+  if (NA_RANK(rblapack_e) != 2)
+    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
+  lde = NA_SHAPE0(rblapack_e);
+  if (NA_SHAPE1(rblapack_e) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
+  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+  e = NA_PTR_TYPE(rblapack_e, real*);
+  ijob = NUM2INT(rblapack_ijob);
+  if (!NA_IsNArray(rblapack_d))
+    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+  if (NA_RANK(rblapack_d) != 2)
+    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
+  ldd = NA_SHAPE0(rblapack_d);
+  if (NA_SHAPE1(rblapack_d) != m)
+    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
+  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_b))
+    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  if (NA_SHAPE1(rblapack_b) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
+  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_f))
+    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
+  if (NA_RANK(rblapack_f) != 2)
+    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
+  ldf = NA_SHAPE0(rblapack_f);
+  if (NA_SHAPE1(rblapack_f) != n)
+    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
+  if (NA_TYPE(rblapack_f) != NA_SFLOAT)
+    rblapack_f = na_change_type(rblapack_f, NA_SFLOAT);
+  f = NA_PTR_TYPE(rblapack_f, real*);
+  if (rblapack_lwork == Qnil)
+    lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
+  else {
+    lwork = NUM2INT(rblapack_lwork);
+  }
+  {
+    na_shape_t shape[1];
+    shape[0] = MAX(1,lwork);
+    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  work = NA_PTR_TYPE(rblapack_work, real*);
+  {
+    na_shape_t shape[2];
+    shape[0] = ldc;
+    shape[1] = n;
+    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+  rblapack_c = rblapack_c_out__;
+  c = c_out__;
+  {
+    na_shape_t shape[2];
+    shape[0] = ldf;
+    shape[1] = n;
+    rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+  }
+  f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*);
+  MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f));
+  rblapack_f = rblapack_f_out__;
+  f = f_out__;
+  iwork = ALLOC_N(integer, (m+n+6));
+
+  stgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);
+
+  free(iwork);
+  rblapack_scale = rb_float_new((double)scale);
+  rblapack_dif = rb_float_new((double)dif);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f);
+}
+
+void
+init_lapack_stgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stgsyl", rblapack_stgsyl, -1);
+}

data/ext/stpcon.c

@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID stpcon_(char* norm, char* uplo, char* diag, integer* n, real* ap, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stpcon(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_norm;
+  char norm; 
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_diag;
+  char diag; 
+  VALUE rblapack_ap;
+  real *ap; 
+  VALUE rblapack_rcond;
+  real rcond; 
+  VALUE rblapack_info;
+  integer info; 
+  real *work;
+  integer *iwork;
+
+  integer ldap;
+  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.stpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPCON estimates the reciprocal of the condition number of a packed\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * 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*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\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\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.stpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 4 && argc != 4)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+  rblapack_norm = argv[0];
+  rblapack_uplo = argv[1];
+  rblapack_diag = argv[2];
+  rblapack_ap = argv[3];
+  if (argc == 4) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  norm = StringValueCStr(rblapack_norm)[0];
+  diag = StringValueCStr(rblapack_diag)[0];
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  if (!NA_IsNArray(rblapack_ap))
+    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
+  if (NA_RANK(rblapack_ap) != 1)
+    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
+  ldap = NA_SHAPE0(rblapack_ap);
+  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
+    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
+  ap = NA_PTR_TYPE(rblapack_ap, real*);
+  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+  work = ALLOC_N(real, (3*n));
+  iwork = ALLOC_N(integer, (n));
+
+  stpcon_(&norm, &uplo, &diag, &n, ap, &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_stpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stpcon", rblapack_stpcon, -1);
+}

data/ext/stprfs.c

@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID stprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stprfs(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_trans;
+  char trans; 
+  VALUE rblapack_diag;
+  char diag; 
+  VALUE rblapack_ap;
+  real *ap; 
+  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; 
+  real *work;
+  integer *iwork;
+
+  integer ldb;
+  integer nrhs;
+  integer ldx;
+  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  ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular packed\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by STPTRS or some other\n*  means before entering this routine.  STPRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\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*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\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 matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\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) REAL array, dimension (LDX,NRHS)\n*          The 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\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 6 && argc != 6)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_trans = argv[1];
+  rblapack_diag = argv[2];
+  rblapack_ap = argv[3];
+  rblapack_b = argv[4];
+  rblapack_x = argv[5];
+  if (argc == 6) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  diag = StringValueCStr(rblapack_diag)[0];
+  if (!NA_IsNArray(rblapack_b))
+    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
+  if (NA_RANK(rblapack_b) != 2)
+    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
+  ldb = NA_SHAPE0(rblapack_b);
+  nrhs = NA_SHAPE1(rblapack_b);
+  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+  b = NA_PTR_TYPE(rblapack_b, real*);
+  n = ldb;
+  trans = StringValueCStr(rblapack_trans)[0];
+  if (!NA_IsNArray(rblapack_x))
+    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+  if (NA_RANK(rblapack_x) != 2)
+    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
+  ldx = NA_SHAPE0(rblapack_x);
+  if (NA_SHAPE1(rblapack_x) != nrhs)
+    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
+  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_ap))
+    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
+  if (NA_RANK(rblapack_ap) != 1)
+    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
+    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
+  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
+    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
+  ap = NA_PTR_TYPE(rblapack_ap, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = nrhs;
+    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = nrhs;
+    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  berr = NA_PTR_TYPE(rblapack_berr, real*);
+  work = ALLOC_N(real, (3*n));
+  iwork = ALLOC_N(integer, (n));
+
+  stprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
+
+  free(work);
+  free(iwork);
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_stprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stprfs", rblapack_stprfs, -1);
+}

data/ext/stptri.c

@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID stptri_(char* uplo, char* diag, integer* n, real* ap, integer* info);
+
+
+static VALUE
+rblapack_stptri(int argc, VALUE *argv, VALUE self){
+  VALUE rblapack_uplo;
+  char uplo; 
+  VALUE rblapack_diag;
+  char diag; 
+  VALUE rblapack_n;
+  integer n; 
+  VALUE rblapack_ap;
+  real *ap; 
+  VALUE rblapack_info;
+  integer info; 
+  VALUE rblapack_ap_out__;
+  real *ap_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  info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPTRI computes the inverse of a real upper or lower triangular\n*  matrix A stored in packed format.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangular matrix A, stored\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same packed storage format.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = i, A(i,i) is exactly zero.  The triangular\n*                matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  A triangular matrix A can be transferred to packed storage using one\n*  of the following program segments:\n*\n*  UPLO = 'U':                      UPLO = 'L':\n*\n*        JC = 1                           JC = 1\n*        DO 2 J = 1, N                    DO 2 J = 1, N\n*           DO 1 I = 1, J                    DO 1 I = J, N\n*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)\n*      1    CONTINUE                    1    CONTINUE\n*           JC = JC + J                      JC = JC + N - J + 1\n*      2 CONTINUE                       2 CONTINUE\n*\n*  =====================================================================\n*\n\n");
+      return Qnil;
+    }
+    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n");
+      return Qnil;
+    } 
+  } else
+    rblapack_options = Qnil;
+  if (argc != 4 && argc != 4)
+    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+  rblapack_uplo = argv[0];
+  rblapack_diag = argv[1];
+  rblapack_n = argv[2];
+  rblapack_ap = argv[3];
+  if (argc == 4) {
+  } else if (rblapack_options != Qnil) {
+  } else {
+  }
+
+  uplo = StringValueCStr(rblapack_uplo)[0];
+  n = NUM2INT(rblapack_n);
+  diag = StringValueCStr(rblapack_diag)[0];
+  if (!NA_IsNArray(rblapack_ap))
+    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
+  if (NA_RANK(rblapack_ap) != 1)
+    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
+  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
+    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
+  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
+    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
+  ap = NA_PTR_TYPE(rblapack_ap, real*);
+  {
+    na_shape_t shape[1];
+    shape[0] = n*(n+1)/2;
+    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+  }
+  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
+  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
+  rblapack_ap = rblapack_ap_out__;
+  ap = ap_out__;
+
+  stptri_(&uplo, &diag, &n, ap, &info);
+
+  rblapack_info = INT2NUM(info);
+  return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_stptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+  sHelp = sH;
+  sUsage = sU;
+  rblapack_ZERO = zero;
+
+  rb_define_module_function(mLapack, "stptri", rblapack_stptri, -1);
+}